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I.  INTRODUCTION 


A.  ADA-BASED  SOFTWARE  TOOLS 

As  ihe  Department  of  Defense’s  commitment  to  the  Ada  language  is  firm, 
there  is  considerable  interest  in  the  development  of  Ada-based,  automated 
software  tools.  The  purpose  of  these  tools  is  to  increase  the  productivity  and 
efficiency  of  software  engineering  efforts.  Ada-based,  automated  metric  tools 
have  been  successfully  implemented  at  the  Naval  Postgraduate  School  in 
response  to  this  need  and  at  the  request  of  Naval  Weapons  Center,  China 
Lake;  specifically,  Neider  and  Fairbank’s  implementation  of  the  Halstead 
Length  Metric  in  a  thesis  entitled  "AdaMeasure”  [Ref.  1],  and  Herzig’s 
extension  of  "AdaMeasure”  to  include  the  Sallie  Henry  and  Dennis  Kafura 
Complexity  Flow  Metric  [Ref.  2J. 

Rather  than  rely  on  a  specific  metric  implementation,  the  design  of 
"AdaMeasure”  incorporates  a  general  top-down,  recursive  descent  parser  to 
collect  the  desired  metric  information.  This  parser  relies  on  the  premise  that 
the  input  code  has  been  correctly  compiled  before  being  analyzed  for  the 
desired  metric  data.  This  assumption  allows  the  parser  to  utilize  a  modified 
Ada  grammar  which  reduces  the  size  and  complexity  of  the  parser  while 
retaining  the  capability  to  parse  an  input  file  in  enough  detail  to  collect 
meaningful  and  relevant  metric  data.  [Ref  l:p.  28] 
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B.  ANALYSIS  OF  REAL-TIME  EMBEDDED  SYSTEMS 

Of  the  available  methods  for  performing  software  analysis,  Leveson  and 
Stolzy  [Ref.  3]  advocate  the  use  of  Petri  nets  as  the  most  viable  method  for 
conducting  a  systems  approach  to  software  analysis.  They  argue  that  a 
systems  approach  is  required  since  real-time  embedded  software  seldom 
works  "in  a  vacuum”.  The  choice  of  Petri  nets  as  a  desirable  method  for 
analysis  is  predicated  on  the  ability  of  Petri  nets  to  model  hardware,  software, 
and  human  behavior  using  the  same  language.  An  added  advantage  is  that 
timing  information  can  be  incorporated  into  the  Petri  net  model  for  analysis  of 
real-time  embedded  systems.  Leveson  and  Stolzy  have  proposed  a  Petri  net 
based  software  analysis  methodology  that  relies  on  deriving  the  untimed 
reachability  graph  of  the  system  Petri  net  model  in  order  to  determine  the 
timing  constraints  and  properties  of  the  final  real-time  imbedded  system. 
Although  principally  concerned  with  software  safety  analysis,  the  analysis 
approach  demonstrated  by  Leveson  and  Stolzy  may  be  used  to  deduce  other 
properties  of  a  real-time  embedded  system.  [Ref.  3] 

Shatz  and  Cheng  [Ref.  4]  were  the  first  to  describe  an  automated,  Petri 
net  based  method  for  static  analysis  of  Ada  programs.  Their  analysis 
approach  consisted  of  the  following  three  steps  /  subsystems  as  illustrated  in 
Figure  1.1: 

1 .  Translation  of  the  source  program  into  a  Petri  net  model. 

2.  Analysis  of  the  Petri  net  model. 

3.  Interpretation  of  the  Petri  net  properties  so  as  to  derive  properties  of 
the  source  program.  [Ref.  4:p.  378| 
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The  Front  End  Translator  Subsystem  utilized  a  multi-pass  translation 
algorithm  and  a  translation  table  that  stored  Petri  net  equivalent  templates 
of  Ada  structures  of  interest.  As  Shatz  and  Cheng  were  specifically  concerned 
with  distributed  programs,  their  translation  scheme  concentrated  on  tasks 
and  their  synchronization  and  communication  mechanisms.  They  did  not 
explicitly  consider  Ada  packages  and  function  program  units.  These  Petri  net 
templates  of  Ada  structures  were  uniquely  labeled,  linked  together  and 
related  to  source  code  on  the  second  pass  through  the  source  code.  This 


Ada  Tasks/Procedures 
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"customization”  of  the  templates  was  based  on  the  premise  that  each 
statement  had  a  unique  statement  number.  [Ref.  4:pp.  378-380] 

For  the  Petri  Net  Analysis  Subsystem,  Shatz  and  Cheng  relied  upon  the 
P-NUT  suite  of  tools  provided  by  Rami  R.  Razouk  of  the  University  of 
California,  Irvine.  [Ref.  4;p.379] 

The  Back  End  Interpreter  /  Display  Subsystem  provided  a  metric  report 
that  related  the  results  of  the  Petri  net  static  analysis  in  the  context  of  the 
source  program  so  as  to  be  an  understandable  and  useful  aid  to  the  Ada 
programmer.  [Ref.  4:p.378] 

The  software  analysis  methodology  proposed  by  Leveson  and  Stolzy 
requires  prior  knowledge  of  the  properties  the  programmer  wants  to  analyze, 
e.  g. ,  what  constitutes  a  fault,  failure,  deadlock,  etc.  [Ref.  3:p.  1].  The 
incorporation  of  this  preliminary  analysis  information  into  an  automated 
software  analysis  tool  suggests  a  capability  to  interactively  query  the  Back 
End  Interpreter  /  Display  Subsystem  rather  than  receive  a  canned  metric 
product.  These  queries  must  be  based  upon  knowledge,  from  either  the 
programmer  or  the  Interpreter  Subsystem,  of  the  source  code  to  Petri  net  place 
mapping. 

Although  principally  concerned  with  a  distributed  software  system’s 
potential  communication  patterns  and  complexity  metrics  [Ref  4.;p.  3’<  7; 

Ref.  5],  Shatz  and  Cheng’s  conceptof  an  automated  petri  net  translator  is 
ideally  suited  to  the  area  of  interactive  software  analysis.  Unfortunately,  the 
exclusion  of  key  Ada  constructs,  the  template  implementation  of  the  Front 
Find  I'ranslalor  Subsystem,  and  the  non-interactive  Back  End  Interpreter 
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Display  Subsystem  limits  the  usefulness  of  Shatz  and  Cheng’s  Analysis 
System  as  a  practical  interactive  software  analysis  tool. 

C.  OBJECTIVES 

It  is  the  objective  of  this  thesis  to  demonstrate  and  implement  an 
algorithm  for  the  automated  translation  of  Ada  source  code  to  a  Petri  net 
model.  This  algorithm  has  an  advantage  over  the  template  algorithm  in  that 
it  requires  only  one  pass  through  the  source  ‘'ode.  In  addition,  the 
intermediate  products  produced  by  this  algorithm  can  facilitate  the  storing  of 
libraries  of  source  code  Petri  net  models.  This  implementation  of  an 
automated  Ada  source  code  translator  utilizes  the  same  parsing  technology  of 
metrics  developed  at  the  request  of  Naval  Weapons  Center,  China  Lake  and  is 
intended  to  be  the  preliminary  work  for  a  new  automated  software  analysis 
tool  entitled  "AdaFlow”,  Although  "AdaFlow”  is  not  intended  to  produce  a 
metric  product,  it  is  designed  to  demonstrate  the  versatility  of  the 
"AdaMeasure”  technology  and  to  be  the  logical  companion  of  the 
"AdaMeasure”  metric  product. 
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II.  RKVIKWOKTHKOIIY 
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A.  PETRI  NETS 

Petri  nets  were  originally  designed  as  a  tool  to  model  communication 
between  asynchronous  components  of  a  computer  system  by  Carl  Petri  [Ref. 
6],  Petri  nets  have  evolved  as  a  modeling  tool  and  have  found  application  in 
such  diverse  areas  of  study  as  software,  hardware,  economics,  and  chemistry. 

A  formal  definition  of  a  Petri  net  is  a  five-tuple,  =  (P,  T,  I,  O,  po). 
where: 

1.  P  =  {pi,  p2,“‘.Pn}  is  a  finite  set  of  places  and  n  ^  0. 

2.  T  =  {t\,  im)  is  a  finite  set  of  transitions;  m  ^  0;  and  the  set  of 
places  and  transitions  are  disjoint,  P  DT  =  0. 

3.  I  is  the  input  function  T  mapping  from  transitions  to  bags  of 

places. 

4.  O  is  the  output  function  T  P",  a  mapping  from  transitions  to  bags  of 
places. 

5.  po  is  the  initial  marking  for  the  net,  P  =>  A  where  N  is  the  set  of 
nonnegative  integers.  [Ref.  3:pp.  396-397] 

A  graph  structure  is  most  often  used  to  illustrate  a  Petri  net.  Standard 
symbols  include  a  circle  "0”  to  represent  a  place  and  a  bar  "  |  ”  to  represent  a 
transition.  An  arrow  or  arc  from  a  place  to  a  transition  defines  the  place  as  an 
input  to  the  transition  while  an  arc  from  a  transition  to  a  place  defines  the 
place  as  an  output  to  the  transition  as  illustrated  in  Figure  2.1.  [Ref  3:p.  387] 
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In  order  to  illustrate  the  dynamic  nature  of  a  system  being  modeled,  Petri 
nets  utilize  tokens.  The  initial  marking,  po.  deposits  zero  or  more  tokens  in 
each  Petri  net  place.  This  marking  corresponds  to  the  initial  state  of  the 
system.  The  net  is  animated  by  the  movement  of  tokens  from  input  places. 


Input  Place 


Transition 


Output  Place 


Marked  Place 


Enabled  Transitions 


Figure  2. 1  Standard  Petri  Net  Symbology 

through  a  transition,  to  output  places.  In  order  for  a  token  to  move,  the 
transition  separating  source  places  and  destination  places  must  be  enabled.  A 
transition  is  enabled  only  if  each  input  place  to  the  transition  contains  at  least 
as  many  tokens  as  there  are  arcs  from  the  input  place  to  the  transition  . 
Examples  of  enabled  transitions  are  shown  in  Figure  2.1.  In  an  untimed  Petri 
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net,  a  transition  may  fire  any  time  after  it  is  enabled.  When  a  transition  fires, 
all  tokens  enabling  that  transition  are  removed  from  their  corresponding 
input  places  and  one  token  is  deposited  in  each  of  the  transition’s  output 
places.  Transitions  continue  to  fire  as  long  as  at  least  one  transition  remains 
enabled.  [Ref.  3] 

The  initial  state  of  the  system  is  defined  by  the  initial  marking,  po-  When 
a  transition  fires,  the  new  marking  of  tokens  defines  a  new  system  state.  For 
an  untimed  Petri  net,  the  enabled  transitions  may  fire  in  any  order.  The  set  of 
all  possible  states  that  may  exist  based  on  all  possible  orderings  of  transition 
firings  defines  the  reachable  states  for  the  system.  In  this  thesis,  a 
reachability  graph  will  he  used  to  illustrate  the  reachable  states  for  a  system. 

A  Time  Petri  net  is  a  Petri  net  that  is  enhanced  to  include  timing 
constraints  on  the  firing  of  transitions.  The  addition  of  timing  information 
may  limit  the  reachable  states  of  the  system,  but  may  never  increase  them. 
This  principle  is  key  to  the  analysis  technique  described  by  Leveson  and 
Stolzy  that  begins  with  the  untimed  reachability  states  of  a  system  and  works 
backward  to  the  real-time  properties  of  a  system.  [Ref.  3:p.  389] 

B.  MODELING  COMPUTER  SOFTWARE 

In  his  description  of  modeling  with  Petri  Nets,  Peterson  claims  that  the 
modeling  of  computer  software  is  "...perhaps  the  most  common  use  of  Petri 
nets  and  has  the  greatest  potential  for  useful  results.”  [Ref.  7;p.  54] 

In  modeling,  a  decision  must  be  made  concerning  which  aspects  of  the  real 
system  are  to  be  incorporated  into  the  model.  When  applied  to  computer 


software,  Petri  net  models  best  illustrate  the  aspect  of  software  control 
structures.  Peterson’s  rationale  for  modeling  control  structures  is  as  follows: 

Petri  nets  are  meant  to  model  the  sequencing  of  instructions  and  the  flow  of 
information  and  computation  but  not  the  actual  information  values 
themselves.  A  model  of  a  system,  by  its  nature,  is  an  abstraction  of  the 
modeled  system.  As  such  it  ignores  the  specific  details  as  much  as  possible. 
If  all  the  details  were  modeled,  then  the  model  would  be  a  duplicate  of  the 
modeled  system,  not  an  abstraction.  [Ref.  7;p.  55] 

As  flowcharts  are  a  standard  means  of  representing  the  control  structures 
of  a  program,  Peterson  utilizes  flowcharts  as  an  intermediate  form  of  the 
source  code  in  the  translation  of  concurrent  computer  software.  In  his 
description  of  the  translation  methodology,  single  processes  in  a  system  of 
concurrent  processes  are  first  described  in  terms  of  flowcharts.  These 
flowcharts  are  translated  to  Petri  nets,  and  then  combined  to  yield  one  Petri 
net  representation  for  a  system  of  concurrent  processes.  [Ref.  7;pp.  54-68] 

The  translation  of  flowcharts  to  Petri  nets  relies  on  the  similarities 
between  these  two  graphical  means  of  representating  of  a  program.  In  a 
flowchart,  nodes  model  actions  or  events,  while  arcs  between  nodes  model 
conditions.  In  a  Petri  net,  the  transitions  model  actions,  while  nodes  model 
conditions.  Peterson’s  translation  is,  therefore,  very  straightfoward:  replace 
the  nodes  of  the  flowchart  with  transitions  in  the  Petri  net  and  the  arcs  of  the 
flowchart  with  places  in  the  Petri  net  as  illustrated  in  Figure  2.2.  Peterson 
describes  a  one-to-one  correspondence  between  flowchart  arcs  and  Petri  net 
places,  while  flowchart  nodes  are  represented  in  different  ways,  depending  on 
the  type  of  the  node:  computation  or  decision  [Ref.  7:  p.  58].  The  combining  of 
Petri  net  models  for  single  processes  into  one  model  representing  a  system  of 
concurrent  processes  is  accomplished  by  introducing  the  concept  of 
parallelism  and  synchronization. 
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Figure  2.2  Translating  Flowcharts  to  Petri  Nets  [Ref  7:p.  57] 


Peterson  describes  three  ways  parallelism  can  be  introduced  into  a 
software  model: 

1.  Simply  take  the  union  of  all  Petri  nets  to  represent  the  concurrent 
execution  of  each  individual  process.  Each  process  has  an  initial 
marking  in  the  place  representing  the  initial  program  counter  for  that 
process. 

2.  Utilize  the  FORK  and  JOIN  operations  originally  proposed  by  Dennis 
and  Van  Horn  [Ref.  8],  The  FORK  and  JOIN  operations  are  illustrated 
in  Figure  2.3. 

3.  Utilize  the  parbegin  and  parend  control  structures  suggested  by 
Dijkstra  [Ref.  9).  This  construct  is  illustrated  in  Figure  2.4. 
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In  his  assessment  of  the  first  method,  Peterson  remarks  that  although  it 
introduces  a  parallelism  that  cannot  be  represented  in  a  flowchart,  it  is  still 
not  a  very  useful  method  of  moc'eling  parallelism  [Ref.  7:p.  59].  The  second 
method  is  a  more  accurate  depiction  of  how  parallelism  would  normally  be 
introduced  into  a  process  in  a  computer  system;  however,  it  limits  the  number 
of  processes  that  may  be  spawned  to  two.  The  parbegin  and  parend  structure 
offers  the  accurate  depiction  of  how  parallelism  would  normally  be  introduced 
without  the  restriction  on  the  number  of  processes  that  may  be  spawned  [Ref. 
7:pp.  59-61] 

The  concept  of  synchronization  entails  the  sharing  of  information  and 
resources  between  individual  processes.  This  communication  between 
processes  must  be  restricted  and  coordinated  in  order  to  ensure  correct 
operation  of  the  overall  system.  Peterson  describes  classic  synchronization 
problems  such  as  the  mutual  exclusion  problem  [Ref.  10],  the  producer  / 
consumer  problem  [Ref.  9],  the  dining  philosophers  problem  [Ref.  9],  and  the 
readers  /  writers  problem  [Ref.  11],  and  presents  some  Petri  net  solutions  to 
these  problems.  As  these  classic  synchronization  problems  do  not  reflect  the 
synchronization  problems  of  a  specific  computer  language,  Peterson  does  not 
relate  his  solutions  to  a  computer  software  translation  algorithm.  His 
solutions  merely  illustrate  general  methods  for  modeling  general  classes  of 
synchronization  problems.  A  discussion  of  Ada’s  synchronization  mechanisms 
and  a  specific  translation  algorithm  will  be  presented  in  Chapter  m.  [Ref.  7: 
pp.  61-69] 

The  procedure  for  modeling  computer  software  outlined  by  Peterson  relies 
on  two  translations:  from  source  code  to  flowchart  and  from  flowchart  to  Petri 
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net.  In  addition,  one  must  then  add  Petri  net  details  in  order  to  model 
parallelism  and  synchronization  mechanisms  between  the  Petri  nets  produced 
from  the  two  translations.  Although  this  procedure  will  ultimately  yield  a 
Petri  net  model  of  the  computer  software  under  study,  it  is  not  a  procedure 
that  is  readily  automated.  The  modeling  algorithm  detailed  by  Shatz  and 
Cheng,  although  specific  to  Ada  software,  overcomes  this  limitation  by 
automating  the  translation  process.  This  modeling  algorithm  required  two 
steps: 

1 .  Preprocessing  of  the  source  code  which  collects  "necessary  information” 
into  some  tables  for  later  reference. 

2.  Translation  of  the  source  code.  [Ref.  4] 

The  preprocessing  step  required  one  complete  pass  through  the  source 
code  to  build  the  tables  required  by  the  translator.  As  one  example  of  what  is 
considered  "necessary  information”  for  the  preprocessor  to  collect,  Shatz  and 
Cheng  describe  the  maintenance  of  an  Entry  Call  Table.  The  Entry  Call 
Table  has  four  fields: 

1.  The  name  of  the  calling  task. 

2.  The  name  of  the  called  task. 

3.  The  name  of  the  entry  in  the  called  task. 

4.  A  unique  identifier  for  the  entry  call. 

In  order  to  uniquely  identify  entry  calls  and  others  information  collected  by 
the  preprocessor,  Shatz  and  Cheng  assume  each  statement  has  a  unique 
statement  number.  [Ref  4:p.  380] 

The  translation  phase  of  the  algorithm  required  a  second  complete  pass 
through  the  source  code.  The  translator  utilized  a  template  table  of  stored 
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Petri  net  equivalent  models  of  Ada  control  structures.  These  Petri  net 
equivalent  models  and  the  resulting  source  program  model  were  stored  and 
described  in  terms  of  a  Petri  net  abstract  grammar.  As  defined  by  Shatz  and 
Cheng,  a  Petri  net  abstract  grammar  is  a  triple  AG  =  (P,  T,  PR),  where; 

1.  P  is  a  finite  set  of  non-terminal  symbols  that  correspond  to  places  in  the 
Petri  net. 

2.  T  is  a  finite  set  of  terminal  symbols  that  correspond  to  transitions  in  the 
Petri  net. 

3.  PR  is  a  finite  set  of  production  rules  of  the  form  u  tv,  where  u  and  v 
are  strings  of  symbols  from  P,  and  t  is  a  sjmibol  from  T. 

An  initial  string  is  used  to  represent  the  initial  marking  of  the  Petri  Net. 
Figure  2.5  illustrates  an  example  Petri  net  model  and  the  corresponding 
abstract  grammar  representation.  [Ref.  4:pp.378-379] 

The  process  of  translating  Ada  constructs  consisted  of  retrieving  the 
appropriate  Ada  construct  model  from  the  template  table,  customizing  the 
templates,  and  linking  the  templates  togethe.**.  Customizing  the  templates 
not  only  uniquely  identifies  places  within  the  templates,  it  also  provides  the 
means  to  automate  the  modeling  of  synchronization  mechanisms  between 
Petri  net  models  of  single  processes.  Consider  the  example  of  Figure  2.6. 

Shatz  and  Cheng’s  templates  for  Ada’s  entry  statement  and  accent  statement 
are  shown  before  customization.  Customization  results  in  the  Ack-entry  place 
for  both  templates  receiving  the  same  unique  identifier.  Therefore,  in  the 
abstract  grammar  representation,  these  two  building  blocks  of  Ada’s 
synchronization  mechanism  are  effectively  linked.  [Ref.  4;p.  380] 


1.  PI  =>  tl  P2  P3  2.  P2  P3  =>  t2  PI 

3.  PI  =»t3P4  4.  P4=i^t4Pl 

with  initial  string  =  PI 


Figure  2.5  An  Abstract  Granunar  Representation 
of  a  Petri  Net  Model  [Ref.  4;p.  384] 


Figure  2.6  Modeling  Ada’s  Synchronization  Mechanism 
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This  algorithm  for  modeling  computer  software  is  superior  to  Peterson’s 
algorithm.  Although  automated,  there  exist  some  notable  shortcomings  that 
prevent  the  use  of  this  template  algorithm  in  a  general,  automated,  Ada 
software  analysis  tool.  These  shortcomings  include: 

1.  The  algorithm  requires  multiple  passes  through  the  source  code.  The 
first  pass  is  utilized  to  determine  the  underlying  structure  of  the 
program,  while  the  second  pass  effects  the  actual  translation. 

2.  The  tables  assembled  in  the  first  pass  do  not  include  scoping 
information  and  , therefore,  do  not  present  a  true  picture  of  the 
program’s  underlying  structure.  In  a  general  Ada  program,  with  and 
use  clauses  can  dramatically  alter  the  context  of  compilation  and 
provide  direct  visability  to  identifiers  without  using  the  "dot”  or 
component  select  notation.  If  the  tables  are  unable  to  provide  scoping 
information,  the  constuct  being  modeled  may  be  misidentified. 

3.  The  method  used  to  depict  parallelism  is  to  provide  an  initial  marking 
for  the  main  procedure  and  each  task  in  the  source  code.  This  is  not  an 
accurate  description  of  of  how  parellellsm  would  normally  be 
introduced  into  a  process.  A  more  accurate  depiction  would  utilize  the 
parbegin  and  parend  structures. 

4.  The  assumption  of  unique  statement  numbers  is,  perhaps,  unrealistic. 
If  by  "statement  number”,  one  refers  to  the  line  of  text  in  the  source 
code  where  the  statement  is  physically  located,  then  the  translation 
algorithm  imposes  restrictions  on  the  language  beyond  those  of  the 
Language  Reference  Manual  (LRM)  [Ref.  12], 
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5.  The  use  of  templates  is  a  rigid  method  that  does  not  accurately  depict 
the  flow  of  control  in  a  general  Ada  program. 

C.  FRONT-END  MACHINE 

Rather  than  rely  on  a  tool  that  was  only  capable  of  gathering  specific 
metric  information,  Neider  and  Fairbanks  chose  to  develop  a  generic  Ada 
front-end  machine  consisting  of  a  lexical  analyzer  and  parser.  This  front-end 
machine  was  used  to  construct  an  intermediate  representation  of  the  source 
program,  or  derivation  tree,  which  is  utilized  to  collect  the  information 
necessary  to  implement  the  desired  metric.  [Ref.  l:p.  18] 

As  this  derivation  tree  determined  the  underlying  structure  of  the 
program  incrementally,  while  the  program  was  being  scanned,  the  desired 
metric  information  could  be  collected  in  one  pass  through  the  source  code. 

This  is  accomplished  by  effecting  emissions  of  the  desired  information  from 
the  front-end  machine  at  appropriate  places  in  the  derivation  tree.  By 
altering  these  emissions  from  metric  information  to  Petri  net  information,  the 
front-end  machine  can  be  utilized  to  translate  Ada  source  code  to  Petri  net 
models. 

1.  The  Modified  Ada  Granunar 

Nieder  and  Fairbanks  decided  on  a  top-down,  recursive-descent 
parsing  algorithm  as  the  implementation  of  the  parser.  Recursive-descent 
parsers  are  closely  related  to  the  LL(1)  subset  of  the  context-free  grammars 
and  are  among  the  most  popular  of  the  compiler  parsers  [Ref.  13:p.  167].  For 
this  reason,  it  was  necessary  to  "massage”  the  Backus-Naur  description  of  the 
Ada  langii  ’e  [Ref.  l2:Appendix  E],  a  non-LL(l)  grammar,  into  an  LL(  l)-like 


grammar  capable  of  being  parsed  deterministically.  In  the  context  of  this 
thesis,  "massage”  refers  to  the  process  of  removing  instances  of  left  recursion 
and  then  left  factoring  the  grammar  so  the  parser  can  choose  the  correct 
production  rule  based  on  one  token  look-ahead.  [Ref.  l:p.  13] 

Nieder  and  Fairbanks  discovered  several  instances  of  left-recursion 
in  the  Ada  grammar.  The  following  excerpt  from  their  thesis  illustrates  Ada’s 
left-recursive  quality  for  the  production  rule  NAME.  Ada’s  terminal  tokens 
will  appear  in  lowercase  letters  while  nonterminals  will  appear  in  upper  case 
letters: 

The  production  rules,  when  taken  directly  from  the  LRM,  appear  as  follows; 

NAME  ^  identifier 

^  character _ literal 

string _ literal 

^  INnRX_COMPONENT 
SLICE 

^  s1':lI';ctei)_componl:nt 
=»  A'lTKIHUTR 

INDKXE()_C0MP0NI-;NT  ^  PREI-'IXi  KXI’RKSSION  > 

SLICE  ^  PREFIX  (  DISCRETE_RANGE) 

SELECTEl)_COMI'ON ENT  PREFIX  .  SELECTOR 

AITRIBL'TE  =>  PREFIX  ’  ATTR1BUTE_I)ESIGNAT0R 

PREFIX  ^  NAME 

^  FCNCTION_CALL 

When  starting  with  NAME  and  substituting  in  the  productions,  the  left 
recursion  becomes  readily  apparent.  For  example: 

NAME  SLICE  PREFLX(I)ISCRETE_RANGE)  =»  NAME(I)ISCRETE_RANGE). 

I  Ref  l  .pp  14  151 

These  instances  of  left  recursion  required  extensive  massaging  in  order  to 
yield  an  LL(  I )  grammar.  The  resulting  grammar  is  included  as  Appendix  A. 
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The  task  of  assembling  a  sequence  of  source  characters  into  the 
terminal  alphabet  or  tokens  of  the  language  is  within  the  province  of  the 


scanner  or  lexical  analyzer  [Ref.  13;p.  18].  There  are  seven  classes  of  tokens 
that  comprise  the  terminals  of  the  Ada  language.  These  token  classes  are 
known  as  identifiers,  separators,  numeric  literals,  delimiters,  comments, 
character  literals,  and  string  literals.  In  addition,  the  Ada  language  recognizes 
a  special  sub-class  of  identifier  known  as  reserved  words. 

The  process  of  lexical  analysis  entails  reading  the  source  program  one 
character  at  a  time  and  building  the  tokens  deterministically,  with  one 
character  look-ahead,  based  upon  the  definition  of  Ada’s  lexical  elements  as 
described  in  Chapter  Two  of  the  LRM  [Ref.  12], 

Neider  and  Fairbanks  described  seven  deterministic  finite  state  machines 
capable  of  recognizing  the  seven  basic  token  classes  of  the  Ada  language. 
These  machines  will  be  discussed  in  greater  detail  in  Chapter  in.  [Ref.  l:pp. 
18-251. 

3.  Recursive-Descent  Parser 

The  implementation  of  Neider  and  Fairbanks’  recursive-descent 
parser  consists  of  a  set  of  function  calls  with  a  one-to-one  correspondence  to 
the  non-terminals  of  the  Modified  Ad-i  Grammar.  These  function  calls  return 
either  a  true  or  false  value.  A  return  of  false  excludes  the  non-terminal  from 
the  derivation  tree  while  a  return  of  true  indicates  that  the  non-terminal  is 
part  of  the  derivation  tree.  As  non  terminals  may  contain  tokens  as  part  of  the 
production  string,  the  parser  can  query  the  lexical  analyzer  if  the  current 
token  matches  a  terminal  in  the  production  string.  If  a  match  is  found,  the 
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token  becomes  a  leaf  of  the  derivation  tree  and  a  new  token  is  assembled  by 
the  lexical  analyzer.  Parsing  begins  with  a  call  to  the  function 
COMPILATION,  the  starting  non-terminal  of  the  grammar  [Ref.  1]. 
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Ill.  THK  1VIKTAM0RPH0S1S0K"AI3A1V1KASUKK” 


"AdaMeasure”  is  an  evolving  metric  tool  that  is  utilized  and  maintained 
by  the  Software  Missile  Branch  of  the  Naval  Weapons  Center,  China  Lake. 
Since  it  was  first  published  in  March  of  1987,  The  "AdaMeasure”  front-end 
machine  has  undergone  a  significant  change  in  appearance  while  retaining 
it’s  basic  functionality.  During  the  course  of  this  thesis,  several  changes  to  the 
lexical  analyzer  and  the  Modified  Ada  Grammar  were  proposed  and 
incorporated.  Changes  to  the  lexical  analyzer  were  made  primarily  in  the 
interest  of  speed  and  readability,  while  changes  to  the  Modified  Ada  Grammar 
were  made  primarily  in  the  interest  of  regularity.  The  first  two  sections  of 
this  chapter  outline  these  general  modifications,  while  the  last  section  details 
the  changes  made  in  the  Parser  (Appendix  C)  emissions  in  order  to  realize  a 
Petri  net  model  of  the  source  code. 

A.  LEXICAL  ANALYZER 

Prior  to  this  thesis,  many  of  the  functional  tasks  of  lexical  analysis  were 
interspersed  throughout  the  different  packages  that  comprised  the  front-end 
machine.  This  thesis  sought  to  group  all  the  functional  tasks  of  lexical 
analysis  into  one  package  with  an  interface  that  hides  the  implementation 
details  as  much  as  possible.  The  result  of  this  efibrt  is  the  Token  Scanner 
package. (Appendix  H).  This  package  presents  an  interface  that,  to  the  user, 
makes  the  source  file  appear  as  a  logical  file  of  Ada  tokens.  A  finite  set  of 
operations  are  provided  to  the  user  that  include  the  ability  to  view  the  token 
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under  the  read  head,  view  the  token  that  will  come  under  the  read  head  next, 
and  the  ability  to  advance  the  read  head  one  token  at  a  time.  In  addition,  the 
capabilities  of  the  Token  Scanner  were  expanded  to  include  the  capability  to 
distinguish  reserved  words  from  identifiers.  This  change  allowed  an  efficient 
hash  search  for  reserved  words  that  was  hidden  from  the  user,  and  resulted  in 
a  significant  increase  in  speed  for  the  front-end  machine. 

The  implementation  of  the  Token  Scanner  utilizes  a  pipe  to  assemble  the 
tokens  of  the  language  and  a  filter  to  prevent  comments  and  separators  from 
ever  coming  under  the  read  head  or  into  the  look-ahead  position.  The  seven 
deterministic  finite  machines  described  by  Nieder  and  Fairbanks  [Ref.  1]  are 
utilized  in  the  pipe  to  identify  the  tokens  as  they  are  assembled.  These 
machines  have  been  enhanced  to  conform  more  closely  to  the  exact  lexical 
requirements  of  the  LRM.  The  only  lexical  requirement  the  Token  Scanner 
does  not  enforce,  is  the  requirement  that  each  extended  digit  of  a  based 
numeric  literal  be  less  than  the  base  [Ref.  12:p.  2-5].  These  enhancements 
have  virtually  eliminated  the  Token  Scanner’s  reliance  on  the  precondition 
that  the  source  code  be  correctly  compiled  prior  to  being  analyzed. 

B.  GRAMMAR 

As  this  thesis  progressed,  it  became  apparent  that  there  were  many 
productions  in  the  Modified  Ada  Grammar  that  could  be  simplified.  Consider 
the  original  productions  that  were  designed  to  parse  an  Ada  function: 
l<’L'NCTION_UNIT=»  DKSIGNATOK  l<'lJNC'nON_UNIT_'rAI I, 

l•'lJNCTION_UNIT_TAII,=^•  is  new  N AMK  |GKNKI{IC_ACTU  A l._PART  ; 

I  I<'0KIV1AI-_PAKT?|  return  NAMK  FUNCTION  ItODY 


KUNCTl()N_HOI)Y  =>  is  I  I•'UNCTI0N_B()^)Y_TA1L  ?| 

; 

FUNCT1()N_B0I)Y_TA1L  =>  separatu  ; 

<  >  ; 

SUBPR()GRAiVI_B01)Y 
=>  NAME; 

These  productions  were  simplified  to  the  following  production  rule: 

KUNCTlON_UNIT=^'  DESIGNATOR! FORM AL_PART?1  return  NAME  is 

SUBPROGRAM_BODY 

=»  DESIGNATOR [KORMAL_PART ’I  return  NAME  ; 

=>  DESIGNATOR  (FORMAL_PART  ?1  return  NAME  renames 
NAME; 

DESIGNATOR  is  SUBPROGRAM_BODY 

Another  significant  change  in  the  grammar  concerned  the  production  rules  for 

SUBPROGRAM _ BODY.  There  were  numerous  instances  of  productions 

requiring  the  sequence: 

lDECLARATlVE_PART?i  begin  SEQUENCE_OK_STATEMENTS  [exception 
[EXCEPTI0N_I1ANDLER|  ^  ?|  end  j DESIGNATOR  ?| ; 

Rather  than  duplicate  this  sequence  for  each  production,  the  productions 

requiring  this  sequence  were  modified  to  utilize  the  SUBPROGRAM _ BODY 

production  rules.  This  simplification  relies  on  the  precondition  of  correctly 
written  code  verified  by  a  compiler  prior  to  being  analyzed.  The  Modified  Ada 
Grammar  listed  in  Appendix  A  contains  all  the  changes  to  the  original 
grammar  and  is  the  current  grammar  utilized  in  both  "AdaMeasure”  and 
"AdaFlow”. 

C.  PARSER  EMISSIONS 
1.  Code  Blocks 

A  key  issue  in  any  source  code  to  Petri  net  translation  algorithm  is 
the  method  used  for  transforming  source  code  space  into  Petri  net  space. 

Shatz  and  Cheng  [Ref.  4|  chose  to  use  "statement  numbers”  that  corresponded 
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to  the  line  of  text  in  the  source  code  where  the  statement  was  physically 
located.  This  method  of  transformation  assumes  that  each  Ada  control 
structure  has  a  unique  statement  or  line  number.  This  assumption  is 
unrealistic  as  it  imposes  restrictions  on  the  language  beyond  those  of  the 
LRM. 

One  method  of  transforming  source  code  space  to  Petri  net  space  is 
suggested  by  the  very  aspect  of  computer  software  Petri  nets  model  best: 
control  structures.  Software  control  structures  not  only  correspond  to 
transitions  in  a  Petri  net,  they  also  serve  to  separate  source  code  into  "blocks” 
of  code  that  correspond  to  unique  Petri  net  places.  It  is  not  sufficient, 
however,  to  rely  on  control  structures  as  the  only  demarcation  of  where  these 
code  blocks  begin  and  end.  One  must  also  consider  the  possible  source  code 
destinations  that  a  control  structure  can  transition  to  when  executed.  These 
possible  destinations  include  labels,  procedures,  functions,  and  task  entries.  In 
general,  a  control  structure  is  located  in  the  current  code  block  and  denotes 
the  end  of  that  code  block,  while  a  destination  denotes  the  end  of  the  current 
code  block  and  is  located  in  the  next  code  block.  The  execution  of  control 
structures  is  simply  the  order  in  which  these  code  blocks  are  interconnected. 

Consider  the  simple  Ada  program  and  corresponding  Petri  net  places 
of  Figure  3.1.  The  procedure  entitled  MAIN  defines  a  destination  of  a 
procedure  call  statement  and,  therefore,  begins  a  new  code  block.  A  procedure 
is  a  scope  defining  construct  that,  when  viewed  from  the  perspective  of  the 
invoker,  can  be  considered  as  one  large  code  block  or  a  super-place  in  the 
corresponding  Petri  net.  The  details  of  control  flow  internal  to  the  procedure 
are  not  visible  to  the  outside  world.  All  the  declarations  that  follow  MAIN  are 
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procedure  MAIN  is 

type  GRADK _ BOOK  is  array  ipositivc  range  O.IOlol 

natural: 

INOKX  :  natural; 

TOTAL :  natural ; 

A  VKRAGK  ;  natural; 

STUDENT :  GRADE_BOOK; 
begin 

INDEX  ;=  0; 

TOTAL  :=  0; 

<  <ADD_AGAIN  >  > 

INDEX  :=  INDEX  +  1; 

TOTAL  :=  TOTAL  + 

STUDENT(INDE’X), 
ifilNDEX  =  lOlthen 
goto  CONTINUE. 

else 

goto  ADD _ AGAI.N; 

end  d"; 

<  <CONTINUE>  > 

AVERAGE  ;=  TOTAL/ 10; 
end  MAIN; 


procedure  MAIN 


Figure  3.1  Transforming  Source  Code  Blocks  to  Petri  Net  Places 


within  the  same  code  block  as  MAIN,  The  reserved  word  begin  labels  the  start 
of  main’s  internal  control  structure  and  starts  a  new  code  block.  The  label 

ADD _ AGAIN  ends  the  first  internal  code  block  and  is  located  in  the  next 

code  block.  The  t/statement  labels  the  root  location  of  a  multi-way  decision 
path  and,  therefore,  is  the  beginning  of  a  new  code  block.  The  first  path  of  the 
if  statement  is  an  unconditional  jump  to  the  label  CONTINUE.  This 
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statement  is  part  of,  and  denotes  the  end  of,  the  if  code  block.  The  else  clause 
of  the  i/" statement  reactivates  the  root  location  as  the  current  code  block.  The 
goto  statement  of  the  second  path  has  the  same  effect  on  the  i/code  block  as 
the  goto  of  the  first  path.  The  end  i/" statement  is  a  possible  destination  for  any 
of  the  paths  of  the  if  statement  and,  as  such,  denotes  the  end  of  the  code  block 
in  the  current  path  if  it  has  not  already  ended.  The  end  i/" statement  begins, 
and  is  located  in,  a  new  code  block.  The  CONTINUE  label  ends  the  end  if  code 
block  and  is  located  in  the  next  code  block.  The  end  of  procedure  MAIN  labels 
a  possible  destination  for  control  statements  such  as  return;  therefore,  it 
denotes  the  end  of  the  current  code  block  and  is  the  first  statement  in  the  next 
code  block.  Upon  completing  the  parse  of  MAIN’s  subprogram  body  we  exit 
the  last  internal  code  block  and  the  enclosing  procedure  code  block. 

A  necessary  condition  for  translation  is  that  for  every  code  block  in 
the  source  program,  there  must  exist  a  unique  Petri  net  place.  This  property 
is  not  commutative  as  pseudo-ploces  exist  in  Petri  nets  that  have  no 
corresponding  code  blocks  in  the  source  program.  These  pseudo-places  will  be 
discussed  when  we  consider  the  Parser’s  emissions  for  Petri  nets. 

Due  to  the  front-end  machine’s  ability  to  determine  the  deep, 
underlying  structure  of  Ada  programs,  it  is  possible  to  determine  when  a  code 
block,  and  the  related  Petri  net  place,  begins  and  ends  on  the  basis  of  where 
we  are  in  the  grammar  rather  than  where  we  are  in  a  text  file.  Based  on  this 
determination,  the  Parser  emits  information  to  the  Code  Blocker  (Appendix 
F). 

The  Code  Blocker  is  responsible  for  assigning  a  unique  Petri  net  place 
number  to  each  code  block  that  is  entered  by  the  Parser.  In  addition,  the  code 


26 


blocker  accepts  and  stores  information  from  the  Parser  that  relates  the  Petri 
net  places  to  their  locations  in  the  text  file.  Although  not  currently  used  by 
the  system,  this  information  is  maintained  for  two  reasons: 

1.  It  is  easier  for  the  user  to  relate  Petri  net  places  to  source  code  locations 
rather  than  grammar  locations. 

2.  It  is  anticipated  that,  at  a  later  date,  an  interactive,  high  level  user 
interface  will  be  incorporated  that  will  require  this  mapping 
information. 

2.  Symbol  Table 

Simply  stated,  the  function  of  a  symbol  table  is  to  store  and  retrieve 
identifiers  and  their  associated  properties.  There  are  two  properties  of 
interest  for  a  source  code  to  Petri  net  translator:  an  identifier’s  attribute  and 
location. 

An  identifier’s  attribute  or  classification  is  used  to  determine 
whether  the  identifier  is  a  control  structure  or  a  possible  destination  of 
executing  a  control  structure.  If  a  control  structure,  the  attribute  uniquely 
classifies  the  type  of  control  structure  that  will  later  be  modeled.  The 
attribute  also  determines  whether  or  not  the  identifier  is  the  beginning  of  a 
new  scope. 

As  Ada  is  a  statically  scoped  language  with  strict  visibility  rules,  any 
symbol  table  used  with  Ada  must  preserve  this  scoping  information.  In 
addition,  an  Ada  symbol  table  must  allow  for  the  capability  to  provide 
visibility  of  identifiers  in  previously  exited  scopes.  This  requirement  is  a  by¬ 
product  of  Ada’s  package  facility. 
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Symbol  table  location  information,  as  it  applies  to  a  Petri  net 
translator,  relates  the  identifier  to  a  unique  code  block  and,  therefore,  a 
unique  Petri  net  place.  As  an  identifier  may  be  declared  before  the  location  or 
code  block  is  known,  the  capability  to  update  an  identifier’s  location  must  be 
supported  by  the  symbol  table. 

By  utilizing  the  location  information  from  the  Code  Blocker,  the 
front-end  machine  has  all  the  additional  resources  required  to  manage  the 
S3mibol  Table  (Appendix  E).  Returning  to  the  example  of  Figure  3.1,  and 
ignoring  the  Parser’s  management  of  the  Code  Blocker  for  entering,  exiting, 
and  reactivating  code  blocks,  the  Parser’s  management  of  the  S3nnbol  Table 
can  be  illustrated. 

When  the  Parser  encounters  the  identifier  MAIN,  it  obtains  the 
current  code  block  number  from  the  Code  Blocker,  say  "1”,  and  inserts  the 
identifier  into  the  Symbol  Table  with  a  procedure  declaration  attribute  and  a 
location  of  "1”.  As  a  procedure  declaration  is  a  scope  defining  construct,  this 
action  causes  the  Symbol  Table  to  enter  a  new  scope. 

The  sequence  of  statements  within  a  procedure  body  may  contain  a 
return  statement.  A  return  statement  is  used  to  complete  the  execution  of  the 
innermost  enclosing  procedure  and  may  be  thought  of  as  an  unconditional 
transfer  to  the  end  of  the  procedure.  For  this  reason,  the  Parser  makes  an 
entry  in  the  symbol  table  for  the  last  code  block  in  the  procedure  with  a  label 
attribute  and  a  location  of  "0”  or  undefined.  As  each  label  in  Ada  must  have  a 
unique  identifier,  the  reserved  word  end  is  used  as  the  identifier  for  the  last 
code  block  in  MAIN.  This  method  of  labeling  destination  code  blocks  that  do 
not  have  a  user  defined  label  ensures  uniqueness  and  avoids  clashes  with  user 
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defined  labels  as  programmers  are  restricted  from  using  a  reserved  word  as  a 
label  identifier. 

The  next  identifier  that  results  in  a  Symbol  Table  entry  is  the  label 

ADD _ AGAIN.  The  Parser  inserts  ADD _ AGAIN  with  a  label  attribute  and 

the  code  block  location,  now  "3". 

^  Upon  parsing  the  i/"statement,  the  Parser  inserts  the  identifier  if  in 

^  the  Symbol  Table  with  a  special  attribute  that  identifies  the  1/ control 

► 

structure  and  the  location  "4”.  This  attribute  causes  the  Symbol  Table  to 
enter  a  new  scope.  The  Parser  then  inserts  the  i/’statement’s  corresponding, 
undefined  end  label. 

The  goto  statement  of  the  first  if  statement  path  causes  the  Parser  to 
search  the  S5mibol  Table  for  the  identifier  CONTINUE.  When  the  Symbol 
Table  informs  the  Parser  that  CONTINUE  is  not  declared,  the  Parser 
assumes  that  the  goto  statement  is  an  implicit  declaration  of  the  label 
CONTINUE.  This  causes  the  Parser  to  insert  a  label  for  CONTINUE  with  an 
undefined  code  block  location  in  the  Symbol  Table.  The  goto  statement  of  the 
second  t/’statement  path  causes  the  Parser  to  search  the  Symbol  Table  for  the 

identifier  ADD _ AGAIN.  The  Symbol  Table  finds  the  label  and  reports  this 

fact  to  the  Parser.  The  Parser  then  checks  to  see  if  the  location  is  defined  (non¬ 
zero).  If  not  defined,  the  Parser  would  update  the  Symbol  Table  entry  to  the 
current  code  block  number. 

The  end  t/’statement  results  in  the  Parser  ordering  the  Symbol  Table 
to  search  for  the  end  label.  When  the  Symbol  Table  finds  the  end  label,  the 
Parser  then  updates  the  label’s  location  to  the  correct  code  block  number  of  "5" 
and  orders  the  Symbol  Table  to  exit  the  scope. 
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When  the  CONTINUE  label  is  encountered,  the  Parser  orders  the 
Symbol  Table  to  search  for  the  identifier  CONTINUE.  The  S5rmbol  Table 
finds  the  label  and  reports  this  fact  to  the  Parser.  The  Parser  then  updates  the 
label’s  location  to  the  current  code  block  number  of  "6”. 

The  end  MAIN  statement  results  in  the  Parser  ordering  the  Symbol 
Table  to  search  for  the  end  label.  When  the  Symbol  Table  finds  the  end  label, 
the  Parser  then  updates  the  label’s  location  to  the  correct  code  block  number  of 
"7”  and  orders  the  S3mibol  Table  to  exit  the  scope.  Figure  3.2  illustrates  the 
scoped  symbol  table  at  the  end  of  the  parse. 


Figure  3.2  Storing  Source  Code  Blocks  in  a  Symbol  Table 


Ada  supports  the  capability  for  a  programmer  to  declare  and  invoke 
procedures,  function,  packages,  tasks  and  entries  before  their  corresponding 
bodies  have  been  parsed.  This  capability  is  akin  to  the  Pascal  forward 
declaration.  In  order  to  handle  these  forward  declarations,  the  Parser  inserts 
the  identifier,  the  appropriate  declaration  attribute,  and  an  unknown 
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location.  The  Parser  then  inserts  the  corresponding  end  label  with  an 
unknown  location  and  exits  the  scope.  When  the  declaration’s  corresponding 
body  is  parsed,  the  Parser  inserts  the  same  identifier,  with  the  appropriate 
body  attribute,  and  the  known  code  block  location.  This  causes  the  Symbol 
Table  to  automatically  search  for  and  update  the  environment  of  definition, 
and  enter  that  environment’s  scope. 

3.  Petri  Net  Transitions 

Petri  net  transitions  model  the  execution  of  control  structures  and 
connect  Petri  net  places.  Petri  net  places  can  be  the  source  or  destination  of  a 
transition  For  the  purpose  of  this  thesis,  Petri  net  places  will  be  divided  into 
three  categories:  known  Petri  net  places,  unknown  Petri  net  places,  and 
pseudo-places.  Known  Petri  net  places  correspond  to  the  code  block  that  is 
currently  being  parsed,  while  unknown  Petri  net  places  correspond  to  either  a 
code  block  declared  in  the  symbol  table,  or  the  next  code  block  to  be 
encountered.  In  all  cases,  known  and  unknown  Petri  net  places  correspond  to 
a  unique  code  block  in  the  source.  Pseudo-places  are  Petri  net  places  that  are 
required  to  model  a  control  structure  but  have  no  corresponding  location  in 
source  code.  As  an  example  of  all  three  places,  consider  Figure  3.3  and  the 
depiction  of  Ada’s  synchronization  mechanism.  When  an  entry  to  a  task  is 
called,  the  procedure  that  called  the  entry  waits  at  the  rendezvous  until  the 
invoked  task  accepts  the  entry  and  finishes  processing  the  accept  statements. 
Only  then  can  the  procedure  that  called  the  entry  continue  processing.  Figure 
3.3  depicts  the  two  transitions  required  to  model  this  control  structure.  The 
current  code  block  is  known  by  the  Parser  when  the  entry  call  statement  is 
encountered.  If  the  assumption  that  this  is  a  correct  Ada  program  is  true, 
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Figure  3.3  Known  Places,  Unknown  Places,  and  Pseudo-Places 

then  the  task  specification  must  have  been  parsed  and  at  least  the  entry  code 
block  and  the  corresponding  end  entry  code  block  are  in  the  Symbol  Table.  It 
is  not  necessary  for  the  locations  to  be  known  yet.  In  order  to  model  the 
requirement  for  the  invoking  procedure  to  wait  at  the  rendezvous  until  the 
accept  statements  of  the  entry  are  through  being  processed,  it  is  necessary  to 
use  a  pseudo-place  that  has  no  corresponding  code  block  in  source  code.  The 
second  transition  models  the  completion  of  the  entry  The  token  from  the 
p.seudo-place  and  the  end  entry  code  block  act  together  to  enable  the  transition 
for  the  invoking  procedure  to  continue  processing. 

In  this  translator,  the  Parser  emits  known  and  unknown  Petri  net 
place  information  together  with  the  type  of  control  structure  to  be  modeled  to 
the  Net  Generator  (Appendix  D).  For  known  Petri  net  places,  the  Parser 
emits  the  current  code  block  number  as  provided  by  the  Code  Blocker.  For 
unknown  Petri  net  places,  the  Parser  emits  a  pointer  or  access  to  the 
appropriate  code  block’s  entry  in  the  Symbol  Table.  The  Net  Generator  is 
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responsible  for  translating  the  control  structure  information  into  transitions 
between  the  known  and  unknown  Petri  net  places.  In  addition,  when  it  is 
necessary  to  use  a  pse ado- place  to  realize  a  model,  the  Net  Generator  grabs  a 
unique  location  from  the  Code  Blocker.  During  the  course  of  this  thesis, 
psuedo-places  were  only  found  necessary  to  realize  models  for  procedure  calls 
and  entry  calls.  All  other  control  structures  were  capable  of  being  modeled  by 
transitions  between  known  and  unknown  Petri  net  places. 

One  special  control  structure  is  used  so  often  it  deserves  special 
mention.  In  the  Net  Generator,  this  special  control  structure  is  called 

CONNECT _ BLOCKS.  Consider  Figure  3.4  which  represents  the  complete 

Petri  net  model  for  the  previous  example  of  Figure  3.1.  The  label 

ADD _ AGAIN,  although  it  siguifies  a  possible  destination  of  a  control 

structure’s  execution,  does  not  constitute  a  break  in  the  sequential  execution 
of  MAIN.  As  the  Parser  knows  the  location  associated  with  the  begin  code 

block,  and  the  location  associated  with  the  ADD _ AGAIN  code  block.  The 

Parser  simply  emits  these  two  known  Petri  net  places  to  the  Net  Generator 
with  the  special  control  structure  CONNECT _ BLOCKS. 

The  Net  Generator  stores  the  Petri  net  model  in  an  abstract 
representation  similiar  to  the  abstract  grammar  described  by  Shatz  and 
Cheng  [Ref.  4] .  The  reason  for  utilizing  an  intermediate  representation  of  the 
Petri  net  model  is  to  give  the  Symbol  Table  and  Parser  an  opportunity  to 
resolve  unknown  Petri  net  places.  By  storing  access  variables  to  the  unknown 
Petri  net  places  in  the  Symbol  Table  as  part  of  the  abstract  representation  of 
the  Petri  net  model,  the  Symbol  Table  will  automatically  update  the  location 
of  unknown  Petri  net  places  referenced  in  the  Net  Generator.  For  the 
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procedure  MAIN  is 

lypeGKADK _ HOOK  is  array  (positive  range  1..10)of 

natural; 

INDKX  :  natural: 

TOTAL :  natural ; 

AVKKAOE  :  natural; 

STUDENT  :GRAI)E_BOOK; 
begin 

INDEX  :=  0; 

TOTAL  :=  0; 

<<AUD_AGAIN>> 

INDEX  :=  INDEX  +  I, 

TOTAL :=  TOTAL  + 

STUDENTlINDEXi; 
ifcINDEX  =  101  then 
goui  CONTINUE; 

else 

goUi  AD[)_AGAIN: 
end  if; 

<<CONTINUE>> 

AVERAGE  :=  TOTAL/ 10; 
end  MAIN; 


procedure  MAIN 


Figure  3.4  Transforming  Control  Structures  to  Transitions 


unknown  places  that  signify  the  next  code  block  to  be  encountered,  the  Net 
Generator  simply  waits  for  the  Parser  to  emit  the  next  control  structure.  If 
the  preceding  model  has  an  abstract  representation  that  ends  with  an 
unknown  place  that  is  not  a  Symbol  Table  code  block,  the  Net  Generator 
chooses  the  next  known  code  block  location  from  the  next  Parser  emission.  As 
a  correct  Ada  program  is  assumed  and  the  question  of  Ada’s  separate 
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compilation  facility  has  not  as  yet  been  addressed  ,  all  unknown  Petri  net 
places  must  be  resolved  by  the  end  of  the  source  code’s  parse.  Only  when  the 
unknown  places  are  resolved  can  we  hope  to  generate  a  valid  Petri  net  model 
of  the  source  code. 

Another  reason  for  utilizing  an  intermediate  representation  of  the 
Petri  net  model  is  that  different  Petri  net  analyzers  may  require  a  different 
specific  input  language.  By  simply  adding  a  translation  algorithm  to  the  Net 
Generator,  the  abstract  representation  of  the  model  can  be  translated  to 
various  Petri  net  analyzer  input  languages.  The  Net  Generator  has  one 
translator  already  defined  for  the  P-NUT  set  of  tools  [Ref.  14]. 


IV.  "ADAFLOW” 


"AdaFlow”  is  a  concept  for  a  Petri  net  based,  interactive  Ada  program 
analyzer.  This  preliminary  work  concentrates  on,  and  suggests  a 
methodology  for,  the  automatic  production  of  Petri  net  models  of  Ada 
programs.  The  products  of  this  translation  method  have  been  tailored  to 
conform  to  the  input  format  of  an  existing  Petri  net  analyzer  entitled  P-NUT. 
The  first  section  of  this  chapter  briefly  describes  the  P-NUT  suite  of  tools  and 
the  capabilities  these  tools  offer.  The  following  sections  of  this  chapter 
describe  in  detail  the  products  produced  by  the  translator  and  the 
environment  in  which  the  translator  and  P-NUT  perform. 

A.  THE  ANALYZER 

P-NUT  is  a  set  of  tools  developed  by  the  Distributed  Systems  Project  in 
the  Information  and  Computer  Science  Department  of  the  University  of 
California,  Irvine.  The  tools  were  constructed  primarily  to  assist  researchers 
in  applying  Petri  net  analysis  techniques  in  the  design  of  distributed  systems. 
The  P-NUT  suite  of  tools  creates  and  manipulates  three  types  of  objects:  Petri 
nets,  reachability  graphs  and  execution  traces. 

Petri  nets  are  input  to  the  system  in  textual  form  and  are  transformed  by 
P-NUT  into  an  internal  representation  of  a  Petri  net.  It  is  the  function  of  the 
translator  to  provide  the  Petri  net  in  this  textual  form.  For  a  complete 
discussion  of  P-NUTs  input  language,  the  reader  is  referred  to  Reference  14. 
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Reachability  graphs  represent  the  state-space  of  a  Petri  net  while 
execution  traces  represent  portions  of  the  state  space.  P-NUT  has  the 
capability  to  produce,  analyze  and  display  both  timed  and  untimed 
reachability  graphs  from  the  internal  representation  of  a  Petri  net.  P-NUT 
also  allows  an  execution  trace  to  be  converted  into  a  partial  reachability  graph 
which  can  be  analyzed  and  displayed  in  the  same  manner  as  a  reachability 
graph  produced  from  the  internal  representation  of  a  Petri  net. 

The  most  powerful  and  innovative  tool  in  P-NUT  is  a  tool  entitled 
Reachability  Graph  Analyzer  (RGA)  (Ref.  15).  RGA  reads  the  internal 
representation  of  a  Petri  net  and  its  associated  reachability  graph  and  allows 
the  user  to  do  computer-assisted,  interactive  analysis,  or  "ask  questions” 
about  the  model,  using  the  language  of  first  order  predicate  calculus  with  the 
addition  of  branching-time  temporal  logic  operators.  This  interactive  analysis 
capability  is  ideally  suited  to  the  concept  of  "AdaFlow”. 

B.  THE  TRANSLATOR  PRODUCT 

The  following  example  demonstrates  the  modeling  capabilities  of  the 
proposed  translation  method  by  producing  a  simple  railroad  crossing  model 
similar  to  the  model  analyzed  by  Leveson  and  Stolzy  [Ref.  3]. 

Figure  4.1  illustrates  the  original  model  used  by  Leveson  and  Stolzy  to 
demonstrate  their  technique  for  analysis  of  real-time  systems.  Although 
there  is  no  combination  of  Ada  control  structures  that  can  exactly  duplicate 
the  places  and  transitions  of  the  model  in  Figure  4.1  the  following  Ada 
program  realistically  portrays  how  an  Ada  task  may  be  written  to  handle  such 
a  problem; 
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Figure  4.1  A  Petri  Net  Model  of  a  Simple  Railroad  Crossing 


procedure  RAIL _ ROAD _ CROSSING  is 

task  COMPUTER  is 
entry  APPROACH; 
entry  DEPART; 
end  COMPUTER; 
taskGATE_KEEPERis 
entry  LOWER_GATE, 

entry  RAISE _ GATE; 

end  GATE_KEEPEK; 
task  body  COMPUTER  is 
begin 
loop 

accept  APPROACH  do 
null; 

end  APPROACH; 

G  ATE_K  E  E  PE  R.  IX)  W  E  R_G  ATE ; 

accept  DEPART  do 
null; 

end  DEPAR'I’; 

GATE_KKEPER  HAISI':_GATE; 
end  lo<)p; 

end  COMPUTER: 


task  body  GATE_KEEPER  is 
begin 
loop 

accept  LOWER_GATE  do 
null; 

end  LOWER_GATK; 

accept  RAISE _ GATE  do 

null; 

end  RAISE_GATE; 
end  loop; 

end  GATE_KEEPER; 
begin 

COMPUTER  APPROACH; 

<  <REEORE_CROSSlNG>  >  null 

<  <WITH1N_CR0SSING>  > 
COMPUTER.  DEPART; 

<  <PAST_CROSSING>  >  null; 
end  RAll._ROAD_CROSSING; 
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The  task  entitled  COMPUTER  represents  the  software  for  the  railroad 

crossing  system,  while  the  task  entitled  GATE _ KEEPER  and  the  main 

procedure  represent  a  test  harness  for  the  COMPUTER  software. 

Assuming  that  this  program  is  stored  in  a  file  entitled  TRAIN2.ADA,  a 
typical  session  with  the  "AdaFlow”  translator  would  begin; 

WELCOME  TO  ADAFLOW 

ENTER  THE  NAME  OF  AN  ADA  SOURCE  FILE  TO  MODEL 
The  user  would  respond  with  TRA1N2.ADA.  The  "AdaFlow”  translator  would 
notify  the  user; 

PARSING  BEGINS 

When  "AdaFlow”  has  finished  the  translation,  it  gives  the  final  message: 

.  PARSE  SUCCESSFUL 

and  exits  to  the  operating  system.  "AdaFlow”  creates  two  files.  The  first  file 
is  named  A.OUT  and  it  contains  the  Petri  net  model  of  the  source  code  written 
in  the  P-NUT  input  language.  The  second  file,  PLACE.DAT,  is  provided  for 
the  user  to  relate  Petri  net  places  to  lines  of  text  in  the  source  code.  For  the 
Ada  program  stored  in  TRAJN2.ADA,  the  A.OUT  file  would  appear  as: 


t1 :  pi  ->  p2,  p3,  p19 

t17:  p26,  p25->  p27 

t2:  p3->  p4 

t18;  p27->  p28,  p29 

t3:  p4  ->  p5 

t19:  p29->  p21,  p30 

t4.  p6,  p5  ->  p7 

t20:  p2->  p3l 

tS;  p7  ->  p8,  p9 

t21;  p31  ->  p6,  p32 

t6:  p9 ->  p22,  plO 

t22:  p8,  p32  ->  p33 

t7:  p24,  plO ->  pn 

t23:  p33  ->  p34 

t8:  p12,  pll  ->  p13 

t24:  p34  ->  p12,  p35 

t9;  pl3  ->  p14,  pis 

t25:  p14,  p35  ->  p36 

tIO;  p15  ->  p26,  p16 

t26:  p36  ->  p37 

til.  p28,  p16->  pi  7 

t27:p30,  p18,  p37->p38 

t12:  p17->  p5.p18 

<p1  > 

t13:  p19->  p20 

t14:  p20->  p21 

t15.  p22,p2l  ->  p23 

tl6:  p23->  p24,  p25 
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The  PLACE.DAT  file  relating  locations  in  the  source  code  to  Petri  net  places 
would  appear  as: 


LOCATION 

CODE  BLOCK  LABEL 

STARTING  LINE 

ENDING  LINE 

pi 

START 

0 

0 

p2 

PROCEDURE  CODE  BLOCK 

1 

40 

P3 

TASK  CODE  BLOCK 

10 

22 

p4 

BEGIN  SUBPROGRAM 

11 

12 

P5 

LOOP  BLOCK 

12 

13 

p6 

ENTRY  BLOCK 

13 

13 

P7 

BEGIN  ACCEPT  STATEMENTS 

13 

14 

p8 

END  ENTRY  BLOCK 

15 

15 

p9 

ENTRY  CALL 

15 

16 

plO 

WAIT  RENDEZVOUS 

0 

0 

p11 

ACCEPT  STATEMENT 

17 

17 

Pl2 

ENTRY  BLOCK 

17 

17 

P13 

BEGIN  ACCEPT  STATEMENTS 

17 

18 

p14 

END  ENTRY  BLOCK 

19 

19 

P15 

ENTRY  CALL 

19 

20 

p16 

WAIT  RENDEZVOUS 

0 

0 

Pl7 

END  LOOP 

21 

21 

p18 

END  SUBPROGRAM 

22 

22 

p19 

TASK  CODE  BLOCK 

23 

33 

p20 

BEGIN  SUBPROGRAM 

24 

25 

P21 

LOOP  BLOCK 

25 

26 

P22 

ENTRY  BLOCK 

26 

26 

P23 

BEGIN  ACCEPT  STATEMENTS 

26 

27 

p24 

END  ENTRY  BLOCK 

28 

28 

P25 

ACCEPT  statement 

29 

29 

p26 

ENTRY  BLOCK 

29 

29 

P27 

BEGIN  ACCEPT  STATEMENTS 

29 

30 

p28 

END  ENTRY  BLOCK 

31 

31 

p29 

END  LOOP 

32 

32 

p30 

END  SUBPROGRAM 

33 

33 

P31 

BEGIN  SUBPROGRAM 

34 

35 

P32 

WAIT  RENDEZVOUS 

0 

0 

P33 

LABELLED  BLOCK 

36 

37 

p34 

LABELLED  BLOCK 

37 

38 

P35 

WAIT  RENDEZVOUS 

0 

0 

p36 

LABELLED  BLOCK 

39 

39 

P37 

END  SUBPROGRAM 

40 

40 

p38 

STOP 

0 

0 

The  places  that  have  a  STARTING  LINE  and  ENDING  LINE  of  "0”  are 


pseudo-places  manufactured  by  the  Net  Generator. 
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Figure  4.2  illustrates  the  Petri  net  model  of  the  train  crossing  produced 
by  AdaFlow.  By  including  a  software  test  harness,  a  Petri  net  model  for  the 
software  and  the  software’s  environment  was  realized.  This  model  is 
significant  in  that  it  is  capable  of  system’s  level,  automated,  interactive 
analysis  for  properties  such  as  safety  and  deadlocks  by  utilizing  RGA. 

It  should  be  noted  that  "AdaFlow”  assumes  that  the  main  procedure  and 
all  declared  tasks  activate  simultaneously  as  modeled  by  the  parbegin  and 
parend  control  structure.  Although  not  shown  in  Figure  4.2,  execution  of  a 
package’s  sequence  of  statements  or  initialization  before  the  parbegin  has 
been  modeled,  but  is  not  reachable.  The  first  code  block  for  a  package’s 
sequence  of  statements  is  never  linked  to  the  rest  of  the  model. 

C.  ENVIRONMENT 

This  preliminary  work  is  written  in  Ada  and  utilizes  the  same  front-end 
machine  as  the  automated  metric  tool  "AdaMeasure”.  "AdaFlow”  was 
originally  written  and  compiled  on  the  Meridian  AdaVantage”*  Compiler 
(Compiler  Release  2.0).  In  order  to  install  and  operate  the  AdaVantage 
compiler,  a  target  system  must  possess: 

•  MS-DOS  or  PC-DOS  version  2. 1  or  later. 

•  A  hard  disk  (typically  SMB  or  larger). 

•  640K  bytes  of  Random  Access  Memory  in  the  base  memory  area. 

In  addition,  an  8087  or  80287  floating  point  math  coprocessor  must  be 
installed  for  programs  that  use  floating  point  operations.  "AdaFlow” 
currently  does  not  require  floating  point  operations. 


AdaVanl  a)4L'  is  a  Iradcmark  of  .Meridian  Software  Systems,  Inc. 
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Figure  4.2  An  AdaFlow  Model  of  3  Simple  RsilroBd  Crossing 
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Release  2.2  of  P-NUT  is  only  suitable  for  systems  running  a  compatible 
version  of  4.2bsd  UNIX'®.  P-NUT  was  successfully  installed  at  the  Naval 
Postgraduate  School  on  a  SUN-3  workstation.  To  facilitate  software  analysis 
in  the  current  form  of  "AdaFlow”,  the  "AdaFlow”  source  code  was  transferred 
to  the  SUN  workstation  and  was  successfully  recompiled  using  VADS*® 

(Verdix  Ada  Development  System,  Version  5.5  for  SUN-3)  without 
modification. 

All  the  P-NUT  software  in  release  2.2  is  available  free  of  charge  from  the 
Information  and  Computer  Science  Department  of  the  University  of 
California,  Irvine.  The  point  of  contact  for  inquiries  concerning  P-NUT  is 
Professor  Rami  Razouk.  Release  2.2  includes  the  C  source  code  and  binaries 
for  SUN-3’s.  If  operating  in  a  different  4.2bsd  UNIX  environment,  a  Makefile 
is  provided  to  facilitate  recompilation  of  the  source  code. 

The  Ada  source  code  for  "AdaFlow”  is  available  free  of  charge  from  the 
Computer  Science  Department  of  the  Naval  Postgraduate  School.  The  point  of 
contact  for  inquiries  concerning  "AdaFlow”  is  LCDR  John  Yurchak. 
Supplementary  information  concerning  compilation  of  the  source  code  is 
provided  along  with  the  source  code. 


UNIX  is  a  rcyislered  trademark  of  the  Hell  System 
VADS  is  a  registered  trademark  of  the  Verdix  Corporation 
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V.  CONCLUSION 


Ada  is  the  Department  of  Defense’s  language  of  choice  for  programming 
embedded,  real-time  systems.  The  decision  to  use  Ada  has  hastened  the  need 
for  Ada-based,  automated  software  engineering  tools.  The  Petri  net-based 
method  proposed  by  Leveson  and  Stohy  for  analyzing  real-time  systems  has 
considerable  merit;  however,  hand  production  of  Petri  net  models  for  large, 
complicated  systems  is  a  tedious  and  error-prone  process  at  best.  This  thesis 
has  described  and  demonstrated  that  an  efficient  method  exists  for  the 
automated  translation  of  Ada  source  code  to  Petri  nets.  By  adding  additional 
features  of  the  Ada  language  such  as  separate  compilation  and  a  library 
manager  to  "AdaFlow”,  the  production  and  analysis  of  Petri  net  models  on  the 
systems  scale  is  possible. 

A.  THE  FUTURE 

As  the  primary  purpose  of  this  thesis  was  to  describe  and  demonstrate  a 
methodology  for  the  translation  of  Ada  source  code  to  Petri  net  models,  not  all 
control  structures  and  features  of  the  Ada  language  have  actually  been 
implemented  in  "AdaFlow";  however,  every  design  decision  was  made  to 
facilitate  the  addition  of  these  features.  For  example,  the  choice  to  utilize  a 
scoped  symbol  table  enables  one  to  capitalize  on  Ada’s  separate  compilation 
facility  at  a  later  date.  By  adding  a  library  manager  to  respond  to  Ada’s  with 
statement,  it  is  possible  to  maintain  a  library  of  Petri  net  models.  These  Petri 
net  models  could  be  of  other  Ada  programs  or  predefined  "environment 
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models”  that  could  be  referenced  like  Ada  programs  for  systems  testing  of  the 
software.  It  is  envisioned  that  a  library  manager  would  operate  by  pre- 
loading  the  Net  Generator  with  a  package’s  Petri  Net  model,  and  the  Symbol 
Table  with  a  package’s  scoped  identifiers  and  properties. 

The  Modified  Ada  Grammar,  although  able  to  parse  a  general  Ada 
program,  was  developed  specifically  with  metrics  in  mind.  There  are  a 
number  of  ways  to  massage  a  grammar  to  appear  LL(1).  In  their 
implementation  of  metrics,  Neider  and  Fairbanks  did  not  have  to  coordinate 
searching  a  scoped  symbol  table  with  the  grammar.  The  massaged  production 
rules  for  NAME  reflect  this  bias.  When  the  same  production  rules  are  used 
while  trying  to  coordinate  the  search  of  a  scoped  symbol  table,  the  grammar 
becomes  hard  to  read  and  difficult  to  use.  In  "AdaFlow”  only  simplistic 
coordination  efforts  were  taken  with  respect  to  the  production  rules  for 
NAME.  It  was  considered  more  important  to  demonstrate  rather  than  perfect 
this  capability.  As  searching  the  scoped  symbol  table  is  necessary  to  ascertain 
if  an  identifier  is  a  procedure  call,  a  function  call,  or  a  task  entry,  the  logical 
candidate  for  change  is  the  grammar.  Future  work  should  include  re¬ 
massaging  this  portion  of  the  Modified  Ada  Grammar  to  facilitate  the 
coordination  of  searching  a  scoped  S)rmbol  table. 

Discussion  of  analysis  of  the  Petri  net  models  produced  by  "AdaFlow”  has 
purposely  been  minimized.  For  the  purpose  of  this  thesis,  it  is  sufilcient  to 
note  that  powerful  automated  analysis  tools  such  as  P-NUT’s  RGA  are 
currently  available.  As  noted  previously,  RGA  utilizes  an  input  language  of 
first  order  predicate  calculus  with  the  addition  of  branching-time  temporal 
logic  operators.  Although  this  method  of  interactive  analysis  is  powerful,  it 
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limits  the  usefulness  of  the  tool  to  those  who  have  a  firm  understanding  of 
predicate  calculus.  Future  work  on  "AdaFlow”  should  include  the  design  and 
addition  of  a  high-level,  user-friendly  interface  to  this  analysis  tool.  This 
interface  should  be  able  to  take  user  queries  and  formulate  the  mathematical 
expressions  understood  by  RGA. 

In  the  train  crossing  example  presented  in  Chapter  FV,  integration  of 
"AdaFlow”  software  models  with  environment  models  was  demonstrated  by 
modeling  a  software  test  harness.  Although  this  method  served  to 
demonstrate  the  principle  of  software  analysis  at  the  system  level,  the  test 
harness  has  limitations  in  modeling  the  true  environment  the  software  may 
encounter.  In  related  Petri  net  research  at  the  Naval  Postgraduate  School, 
Lewis  (Ref.  16)  describes  the  analysis  of  a  proposed,  but  never  developed,  real¬ 
time  embedded  missile  software  package.  This  analysis  is  conducted  at  the 
system  level  using  Petri  net  models  of  the  environment  constructed  by  hand. 
Further  research  into  using  "AdaFlow”  to  automate  the  integration  of  these 
environment  models  with  the  software  under  analysis  is  warranted. 

It  is  hoped  that  as  the  concept  and  features  of  "AdaFlow”  are  fully 
developed,  this  software  tool  will  become  a  valuable  aid  in  the  design  and 
testing  of  Ada  programs  for  real-time,  embedded  applications. 
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AIM^HNDIX  A 


MOniKlKI)  ADA  GRAM1V1AR 


(9.10) (parserS) 

ABORT_STATEIV!ENT  ^  NAME  [,  NAME)*  ; 

(9.5)  (parserl) 

ACCEPT_STATEMENT  identifier  ((EXPRESSION)  ?]  (FORMAL_PART  ?1 

[doSEQU£NCE_OF_STATEMENTSend  [identifier  ’]  ?] 

(4.3)  (parser3) 

AGGREGATE  (COMPONENT_ASSOCIATlON  (,  COMPONENT_ASSOCIATION]*  ) 

(4.8)  (parser3) 

ALLOCATOR  ^  SUBTYPE_INDICAT10N  ['AGGREGATE  '>] 

(3.6)  (parserS) 

ARRAY_TYPE_DEFINITION  ^  (INDEX_CONSTRAINT  of  SUBTYPE_1NDICATI0N 

(5.2)  (parser2) 

ASSIGNMENT_OR_PROCEDURE_CALL  =>  NAME  :=  EXPRESSION  ; 

NAME  ; 


(4.1.4)  (parser3) 

ATTRIBUTE_0£StGNATOR  identifier  [(EXPRESSION)  ?) 

==^  range  [(EXPRESSION)  ?! 

=»  digits  [(EXPRESSION)?] 
delta  [(EXPRESSION)  ?] 

(3.1) (parserl) 

BASIC_DECLARATION  type  TYPE_DECLARATION 

~  subtype  SUBTYPE_DECLARATION 

procedure  PROCEDURE  UNIT 
^  function  FUNCTION^UNIT 

=»  package  PACKAGE J^ECLARATION 

=>  generic  GENERIC_D.ECLARATION 

IDENTIFIER_DECLARATION 
=?  task  TASK_DECLARATI0N 

(3.9) (parserl) 

BASIC_DECLARATIVE_ITEM  BASIC_DECLARATIVE 

~  ^  REPRESENTATION_CLAUSE 

^  use  WITH  OR  USE  CLAUSE 
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(10.1) (parserO) 

BASIC_UNIT  =»  LIBRARY_UNIT 
SUBUNIT 

(4.5)  (parser4) 

BINARY_ADDING_OPERATOR  + 

=»  - 
=5*  & 

(5.6)  (parserl) 

BLOCK_STATEMENT  [declare  DECLARATIVE_PART  ?]  begin 

SEQUENCE_0F_STATEMENTS  [exception 
[EXCEPTION  HANDLER] '  ?]  ?]  end  [identifier  ?] ; 


(5.4)  (parserl) 

CASE  _STATEI\/IENT  =»  EXPRESSION  is  [CASE_STATEMENT_ALTERNATIVEr  end  case  ; 
(5.4)  (parserl) 

CASE_STATEMENT_ALTERNATIVE  =>  when  CHOICE  [|  CHOICE]*  => 

SEQUENCE  OF  STATEMENTS 


(3.7.3)  (parser3) 

CHOICE  =>  EXPRESSION  [  .SIMPLE_EXPRESSION  ?] 

EXPRESSION  [CONSTRAINT  ?] 

^  others 

(10.1) (parserO) 

COMPILATIONS  [COMPILATlON_UNIT]- 

(10.1)  (parserO) 

COMPIUVTlON_UNIT  S  CONTEXT_CLAUSE  BASIC_UNIT 

(4.3)  (parser3) 

COMPONENT_ASSOCIATION  S  [CHOICE  [j  CHOICE]*  =  >  ?]  EXPRESSION 

(3.7)  (parser2) 

COMPONENT_DECLARATION  S  IDENTIFIER_LIST  :  SUBTYPE_INDICATION 

[:  =  EXPRESSION  ?]  ; 

(3.7)  (parser2) 

COMPONENT_LIST  S  [COMPONENT_DECLARATION]*  lVARIANT_PART  ?] 
S  null  ; 

(5.1)  (parserl) 

COMPOUND_STATEMENT  S  if  IF_STATEMENT 

S  caseCASE_STATEMENT 
S  LOOP_STATEMENT 
S  BLOCK_STATEMENT 
S  accept  ACCEPT_STATEMENT 
S  SELECT  STATEMENT 
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(3.2)  (parser2) 

CONSTANT_TERM  ^  array  ARRAY_TYPE_DEFINITION  [:  =  EXPRESSION?]; 
=»  :  =  EXPRESSION  ; 


(3.3.2)  (parser3) 

CONSTRAINT  =>  range  RANGES 
range  <  > 

=J-  digits  FLOATING_OR_FIXED_POINT_CONSTRAINT 
=»  delta  FLOATING_OR_RXED_POINT_CONSTRAINT 
=>  (INDEX_CONSTRAINT 

(10.1)  (parserO) 

CONTEXT_CLAUSE  [with  WITH_OR_USE_CLAUSE 

[use  WITH_OR_USE_CLAUSEr  ]* 

(3.9)  (parserl) 

DECLARATIVE_PART=>  [BASIC_DECLARATIVE_ITEM]*  [LATER_DECLARATIVE_ITEM]* 

(9.6)  (parser3) 

DELAY_STATEMENT  SIMPLE_EXPRESSION  ; 

(6.1)  (parser2) 

DESIGNATOR  identifier 

^  string  literal 


(3.6)  (parser3) 

DISCRETE_RANGE  RANGES  [CONSTRAINT  ?] 

(3.7.1)  (parser2) 

DISCRIMINANT_PART  =i>  (DISCRIMINANT_SPECIFICATION 

[;  DISCRIMINANT  SPECIFICATION]*) 


(3.7.1)  (parser2) 

DISCRIMINANT_SPEClFICATION  =>  IDENTIFIER_LIST  ;  NAME  [;  =  EXPRESSION  ?] 

(9.5)  (parser2) 

ENTRY_DECLARATION  =»  entry  identifier  ((DISCRETE_RANGE)  ?] 

[FORMAL_PART  ?] ; 

(3.5.1)  (parser4) 

ENUMERATION_LITERAL  =»  identifier 

character _ literal 

(3.5.1)  (parser4) 

ENUMERATION_TYPE_DEFINITION  =»  (ENUMERATION_LITERAL 

[.ENUMERATION  LITERAL]*) 


(11.1)  (parser2) 
EXCEPTION_CHOICE  =»  NAME 
=?  others 
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(11.2) (parserl) 

EXCEPTlON_HANDLER  =^-  when  EXCEPTION_CHOICE  l|  EXCEPTION_CHOICE]* 

=  >5EQUENCE_0F_STATEMENTS 

(8.5)  (parser2) 

EXCEPTION_TAIL  =»  ; 

^  renames  NAME ; 


(5.7)  (parsers) 

EXIT_STATEMENT  =>  [NAME  ?]  [when  EXPRESSION  ?] ; 

(4.4)  (parsers) 

EXPRESSION  =>  RELATION  [RELATION_TAIL  ?] 

(4.4)  (parsers) 

FACTOR  PRIMARY  [••  PRIMARY  ?) 

abs  PRIMARY 
=»  not  PRIMARY 

(5.5.7)  (parsers) 

FLOATING  OR_FIXED_POINT  CONSTRAINT  SIMPLE_EXPRESSION  [range  RANGES 

(6.4)  (parser4) 

FORMAL_PARAMETER  =»  identifier  =  > 

(6.1)  (parser2) 

FORMAL_PART  =»(PARAMETER_SPECIFICATION  [;  PARAMETER_SPECIFICATIONl*  ) 

(6.1)  (parserl) 

FUNCTION_UNIT  DESIGNATOR  [FORMAL_PART  ?]  return  NAME  is 

SUBPROG  RAM_BODY 

DESIGNATOR  [FORMAL_PART  ?]  return  NAME  ; 

^  DESIGNATOR  [FORMAL _ PART  ?]  return  NAME  renames  NAME  ; 

DESIGNATOR  is  SUBPROGRAM  BODY 


(12.1) (parser2) 

GENERIC_ACTUAL_PART  (GENERIC_ASSOCIATION  [,  GENERIC_ASSOCIATION]*  ) 

(12.1)  (parser2) 

GENERIC_ASSOCIATION  [GENERIC_FORMAL_PARAMETER  ?]  EXPRESSION 

(12.1)  (parserl) 

GENER1C_DECLARATI0N  =>  [GENERIC_PARAMETER_DECLARATION  ]* 

GENERIC  FORMAL  PART 


(12.1) (parser2) 

GENERlC_FORMAL_PARAMETER  ^  identifier  =  > 

^  string  literal  =  > 
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(12.1) (parserl) 

GENERIC_FORMAL_PART  =>  procedure PROCEDURE_UNIT 

function  FUNCTION_UNIT 
^  package  PACKAGE_DECLARATION 

(12.1)  (parserl) 

GENERIC_PARAIV1ETER_0ECLARATI0N  =>  IDENT1FIER_LIST  :  [MODE  ?]  NAME 

[:  =  EXPRESSION  ?] ; 

^  type  private  [DISCRIMINANT _ PART  ?] 

is  PRIVATE_TYPE_DECLARATION  ; 

=>  type  private  [DISCRIMINANT_PART  ?] 
isGENERIC_TYPE_DEFINITION  ; 

with  procedure  PROCEDURE _ UNIT 

with  function  FUNCTION_UNIT 

(12.1)  (parser2) 

GENERIC_TYPE_DEFINITION  (  <>  ) 

range  <  > 

^  digits  <  > 
delta  <  > 

=>  array ARRAY_TYPE_DEFINITION 
=>  access SUBTYPE_INDICATION 

(5.9)  (parser3) 

GOTO_STATEMENT  ^  NAME  ; 

(3.2)  (parser2) 

IDENTIFIER_DECLARATION  =^IDENTIFIER_LIST  ;  IDENTIFIER_DECLARATION_TAIL 

(3.2)  (parser2) 

IDENTlFIER_DECLARATION_TAIL  =»  exception  EXCEPTION_TAIL 

constant  CONSTANT _ TERM 

=»  array ARRAY_TYPE~DEFINITION 
[:  =  EXPRESSION  ?J  ; 

NAME  IDENTIFIER_TAIL 

(3.2)  (parser2) 

IDENTIFIER  LIST  identifier  [,  identifier)* 

(3.2)  (parser2) 

IDENTIFIER_TAIL  [CONSTRAINT  ?][;=  EXPRESSION ’) ; 

[renames  NAME  ?) ; 

(5.3)  (parserl) 

IF_STATEMENT  ^  EXPRESSION  then  SEQUENCE_0F_STAT:MENTS 

[elsif  EXPRESSION  then  SEQUENCE_OF  STATEMENTS]*  [else 
5EQUENCE_0F_STATEMENTS  ?]  end  ifT 

(3.6) (parserS) 

INDEX  CONSTRAINT  =»  DISCRETE  RANGE  [,  DISCRETE  RANGE]*) 
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(3.5.4)  (parsers) 

INTEGER_TYPE_DEFINITION  =»  range  RANGES 

(5.5)  (parsers) 

ITERATION_SCHEME  =»  while  EXPRESSION 

=>  for  L00P_PARAMETER_SPEC1FICATI0N 

(5.1)  (parsers) 

LABEL  =>  <<  identifier  >  > 

(3.9)  (parserl) 

LATER_DECLARATIVE_ITEM  =>  PROPER_BODY 

generic  GENERIC_DECLARATION 
=4>  use  WITH_OR_USE_ClAUSE 

(4.1)  (parsers) 

LEFT_PAREN_NAME_TAIL  =»  (FORMAL__PARAMETER  ?]  EXPRESSION  [..EXPRESSION  ?] 

[,  [FORMAL_PARAMETER  ?]  EXPRESSION 
[EXPRESSION?]]*)  [NAME  TAIL]* 


(10.1)  (parserO) 

L1BRARY_UNIT  =>  procedure  PROCEDURE_U NIT 
function  FUNCTION_UNIT 
=>  package  PACKAGE_DECLARATION 
=»  generic  GENERIC_DECLARATION 

(5.5)  (parsers) 

LOOP_PARAMETER_SPECIFICATION  identifier  in  [reverse  ?]  DISCRETE_RANGE 

(5.5)  (parserl) 

LOOP_STATEMENT  =>  [ITERATION_SCHEME  ?]  loop 

SEQUENCE_OF_STATEMENTS  end  loop  [identifier  ?] ; 

(6.1)  (parsers) 

MODE  =»  [in?] 

=>  in  out 
^  out 

(4.5)  (parser4) 

MULTIPLYING_OPERATOR  =»  * 

^  / 

=>  mod 
=>  rem 

(4.1)  (parserS) 

NAME  identifier  [NAME  TAIL?] 

character  literalTNAME  TAIL?] 

=>  string  literal  [NAME  TAIL’] 
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(4.1)  (parsers) 

NAME_TAIL  =»  (LEFT_PAREN_NAME_TAIL 
=»  SELECTOR  [NAME_TAIL]* 

=>  'AGGREGATE  [NAME_TAILl* 

=»  ■ATTRIBUTE_DESIGNATOR  (NAME_TAILl* 

(7.1)  (parserl) 

PACKAGE_DECLARATION  body  identifier  is  SUBPROGRAM_BODY 

^  identifier  is  PACKAGE  TAIL  END 
^  identifier  renames  NAME; 


(7.1)  (parserl) 

PACKAGE_TAIL_END  =J>  new  NAME  [GENERIC_ACTUAL  PART  ?] ; 

=>  [BASIC_DECLARATIVE_ITEM]*Tpnvate 

[BASIC  DECLARATIVE  ITEM]*  ?]  end  [identifier  ?] ; 


(6.1)  (parser2) 

PARAMETER_SPECIFICATION  =»  IDENTIFIER_LIST  :  MODE  NAME  [:  =  EXPRESSION  ’] 

(4.4)  (parsers) 

PRIMARY  numeric  literal 
^  null 

string  literal 
new/dlOCATOR 
=»  NAME 
=»  AGGREGATE 

(7.4)  (parser2) 

PRIVATE_TYPE_DECLARATION  =»  [limited  ?]  private 

(6.1)  (parserl) 

PROCEDURE_UNIT  =»  identifier  [FORMAL_PART  ?]  is  SUBPROGRAM_BODY 

^  identifier  [FORMAL _ PART  ?] ; 

^  identifier  [FORMAL~PART  ?]  renames  NAME  ; 

(S.9)  (parserl) 

PROPER_BODY  =>  procedure  PROCEDURE_UNIT 
=>  function  FUNCTION_UNIT 

^  package  PACKAGE _ DECLARATION 

=>  task  TASK_DECARATION 

(5.5)  (parserS) 

RANGES  =»SIMPLE_EXPRESSION  [  .SIMPLE_EXPRESS10N  ’] 

(11. 5)  (parserS) 

RAISE_STATEMENT  =>  [NAME  ?]  ; 

( 1S.4) (parser2) 

RECORD_REPRESENTATION_CAUSE  =>  [at  mod  SIMPLE_EXPRESSION  ?] 

(NAME  at  SIMPLE_EXPRESSION  range 
RANGES]*end  record  , 
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(3.7)  (parser2) 

RECORD_TYPE_DEFINmON  =>  COMPONENT_LIST  end  record 

(4.4)  (parser3) 

RELATION  SIMPLE_EXPRESSION  [SIMPLE_EXPRESSION__TAIL  ?] 

(4.4)  (parser3) 

RELATION_TAIL  [and  (then  ?]  RELATION)* 

=»  [or  [else  ?1  RELATION)* 

=>  [xor  RELATION)* 

(4.5)  (parser4) 

RELATIONAL_OPERATOR  = 

=»  /  = 

< 

<  = 

> 

>  = 

(13.1) (parser2) 

REPR£SENTATION_CLAUSE  for  NAME  use  record 

RECORD  REPRESENTATION_CLAUSE 
=»  for  NAME  uselat  ?)  SIMPLE  EXPRESSION; 


(5.8)  (parser3) 

RETURN_STATEMENT  [EXPRESSION  ?) , 

(9.7.1)  (parserl) 

SELECT_ALTERNATIVE  [when  EXPRESSION  =  >  ?)  accept  ACCEPT_STATEMENT 

[SEQUENCE_OF_STATEMENTS  ?) 

=i>  [when  EXPRESSION  =  >  ?)  delay  DELAY_STATEMENT 
[SEQUENCE_OF_STATEMENTS  ?) 

[when  EXPRESSION  =  >  ?)  terminate  ; 

(9.7.1)  (parserl) 

SELECT_ENTRY_CALL  ^  else SEQUENCE_OF_STATEMENTS 

or  delay  DELAY  STATEMENT 

[SEQUENCE~OF_STATEMENTS  ?) 

(9.7)  (parserl) 

SELECT_STATEMENT  =>  select  SELECT_STATEMENT_TAIL  [  SELECT_ENTRY_CALL  ?) 

end  select ; 


(9.7.1)  (parserl) 

SELECT_STATEMENT_TAIL  =>  SELECT  ALTERNATIVE  (or  SELECT_ALTERNATIVE)* 
~  NAME  ;TSEQUENCE  OF  STATEMENTS?) 


(4.1.3) (parser4) 

SELECTOR  identifier 

=>  character  literal 
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=>  string _ literal 

all 

(5.1)  (parserl) 

SEQUENCE_OF_STATEMENTS  =>  [STATEMENTl’ 

(4.4)  (parsers) 

SIMPLE_EXPRESSION  [  +  ?]  TERM  [BINARY_ADDING_OPERATOR  TERM)* 

[-?]  TERM  [BINARY  ADDING  OPERATOR  TERM)* 


(4.4)  (parsers) 

SIMPLE_EXPRESSION_TAIL  RELATIONAL_OPERATOR  SIMPLE_EXPRESSION 

=>  [not  ?]  in  RANGES 
=»  [not?)  in  NAME 

(5.1)  (parser2) 

SIMPLE_STATEMENT  =>  null  ; 

=>  ASSIGNMENT_OR_PROCEDURE_CALL 
exit  EXIT_STATEMENT 
return  RETURN_STATEMENT 
=>  goto  GOTO_STATEMENT 
=>  delay  DELAY_STATEMENT 
=»  abort  ABORT_STATEMENT 
raise  RAISE_STATEMENT 

(5.1)  (parserl) 

STATEMENT  [LABEL  ?]  SIMPLE_STATEMENT 

=»  [LABEL  ?1  C0MP0UND_STATEMENT 

(6.3) (parserl) 

SUBPROGRAM_BODY  new  NAME  [GENERIC_ACTUAL_PART  ?] ; 

separate ; 

=»  <  >  ; 

=»  [DECLARATIVE_PART  ?)  [begin  SEQUENCE_OF_STATEMENTS 
[exception  [EXCEPTION_HANDLERl  ’  ?)?)  end  [DESIGNATOR  ?) ; 
NAME; 

(3.3.2)  (parser2) 

SUBTYPE_OECLARATION  identifier  is  SUBTYPE_INDICATION  ; 

(3.3.2)  (parser3) 

SUBTYPE_INDICATION  =>  NAME  [CONSTRAINT  ?) 

(10.1)  (parserO) 

SUBUNIT  =»  separate  (NAME)  PROPER_BODY 

(9.1)  (parserl) 

TASK_DECLARATION  body  identifier  is  SUBPROGRAM_BODY  ; 

[type  ?]  identifier  [is  [ENTRY_DECLARATIONl* 

[REPRESENTATION  CLAUSE]*  end  [identifier  '’1  ’1  ; 
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(4.4)  (parsers) 

TERM=>  FACTOR  [MULTIPLYING_OPERATOR  FACTORl* 

(3.3.1)  (parser2) 

TYPE_DECLARATION  =>  identifier  [DISCRIMINANT_PART  ?] 

[is  PRIVATE_TYPE_DECLARAT10N  ?1 ; 
identifier  [DISCRIMINANT  PART  ?] 
[isTYPE_DEFINITION?I; 

(3.3.1)  (parser2) 

TYPE_DEFINITION  ENUMERATION_TYPE_DEFINITlON 
=»  INTEGER_TYPE_OEFINITION 

=>  digits  FLOATING_OR_FIXED_POINT_CONSTRAINT 
=»  delta  FLOATING_OR_FIXED_POINT_CONSTRAINT 
^  array  ARRAY_TYPE_DEFINITION 
=»  record  RECORD_TYPE_DEFINITION 
=»  access  SU8TYPE_INDICATION 
^  newSUBTYPE_INDICATION 

(3.7.3)  (parser2) 

VARIANT  when  CHOICE  [|  CHOICE]*  =  >  COMPONENT_LIST 

(3.7.3)  (parser2) 

VARIANT PART  case  identifier  is  [VARIANT]  *  end  case ; 

(10.1.1)  (parser2) 

WITH  OR  USE  CLAUSE  identifier  [,  identifier]*  ; 


APPENDIX  B 


”ADAFLOW”  PROGRAM  IJSTING  -  MAIN 


TITLE; 

ADAFLOW 

MODULE  NAME; 

PROCEDURE  MAIN 

-- 

FILE  NAME: 

MAIN. AOA 

-- 

DATE  CREATED: 

02 

FEB  88 

-- 

LAST  MODIFIED: 

28 

APR  88 

-- 

AUTHOR(S) : 

LT 

ALBERT  J,  GRECCO, 

,  USN 

DESCRIPTION: 

This 

procedure  is  the 

highest  level  procedure  -- 

of  AOAFLOW.  It  queries  the  user  for  an  ADA 
program  to  model,  sets  up  the  token  matcher, 
starts  the  parser  through  the  ADA  program,  and  -- 
translates  the  results  of  the  parse  to  P-NUT 
code. 


»ith  rOK£N_MArCHER,  COD£_BLOCK£R,  SYM80L_rABL£ , 
NET_GEN£RATOR,  PARSER,  TEXT_[0; 


procedure  MAIN  is 

SOURCE_COOE_FILE  :  string  (1..80)  ;=  (others  =>  '  '): 
SOURCE_COOE_FILE_LENGTH  :  natural; 

procedure  GET  FILENAME  is 
UNKNOWN_NAME  :  exception; 
use  TEXTIO; 
begin 

putl ine( "WELCOME  TO  AOAFLOW");  newline; 

put_l ine( "ENTER  THE  NAME  OF  AN  AOA  SOURCE  FILE  TO  MODEL");  new) me; 
SOURC£_CODE_FILE  :=  (others  ->  '  '); 

get_line(SOURCE_COOE  FILE,  SOURCt_CODE_FILE_LENGTH) ;  newline; 
if  (SOURCE_COOE_FILE_LENGTH  =  0)  then 
raise  UNKNOWN  NAME ; 
e  1  se 

put_l ine(SOURCE_CODt_FIl E( I . . SOURCE  COOE  F I LE  LENGTH ) ) ; 
end  if; 

end  GET  FILE  NAME; 
beg  in 
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GET_FILE_NAME; 

T0KEN_MATCHER.SET_UP_T0KEN_MATCHER(S0URCE_C0DE_FILE(1.  . 

SOURCE_CODE_FILE_LENGTH) ) 

TEXT_IO.put_l ine( "PARSING  BEGINS 
if  PARSER. ISPARSED  then 
TEXT_IO.put_l ine( "  .  .  ,  PARSE  SUCCESSFUL"); 

NET_GENERATOR . TRANSLATE_TO_PEANUT ; 
else 

TEXT_IO.putJine(".  .  .  PARSE  UNSUCCESSFUL"); 
CODE_BLOCKER.CLEAR_COOE_BLOCXER; 

NETGENERATOR . RESET_NET_GENERATOR ; 
end  if; 

SYMBOL_TABLE .CLEAR^SYMTAB; 

T0KEN_MATCHER . RELEASE_T0KEN_MATCHER  ; 
exception 

when  others  => 

TEXT_I0.put_1ine( "UNABLE  TO  MODEL  AOA  SOURCE  CODE"); 

TEXT_IO.put_line(".  .  .  PARSE  UNSUCCESSFUL"); 

COOE_BLOCKE  R . CLEAR_CODE_BLOCKER ; 

NETGENERATOR . RESET_NET_GENERATOR; 

SYMBOL_TABLE .CLEAR_SYM_TAB; 
begin 

TOKEN_MATCHER.RELEASE_TOKEN_MATCHER; 

exception 

when  others  =>  nul 1 ; 
end ; 
end  MAIN; 
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APPKNDIXC 


"ADAFf.OW”  PROGRAM  LISTING  -  PARSER 


TITLE; 

ADA FLOW 

MODULE  NAME; 

PACKAGE  PARSER 

-- 

FILE  NAME; 

PARSER. ADS 

--- 

DATE  CREATED; 

18 

FEB  88 

LAST  MODIFIED: 

28 

APR  88 

AUTHOR(S) : 

LT 

ALBERT  J.  GRECCO,  USN 

DESCRIPTION; 

This 

package  defines  the  only  Interfaces  to 

-- 

to  the  parser.  Packages  PARSER_Q  through  PARSER_4 
exist  only  as  local  packages  to  package  PARSER  and  are 
not  user  accessable. 


package  PARSER  is 

function  IS_PARS£0  return  boolean; 

--  pre  -  TOKEN_MATCHER,  SYM60L_TABLE ,  COOE_8LOCKER ,  and  NET_GENERATOR  are 
1 n  i  t i all  zed  . 

--  post  -  If  the  file  being  parsed  is  a  valid  ADA  program.  IS_PARSED 
is  TRUE  else  IS_PARSED  is  FALSE. 

end  PARSER: 
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TITLE: 

ADAFLOW 

MODULE  NAME: 

PACKAGE  PARSER 

-- 

FILE  NAME: 

PARSER. AOB 

-- 

DATE  CREATED: 

18 

FEB  88 

LAST  MODIFIED; 

28 

APR  88 

-- 

AUTHOR(S) : 

LT 

ALBERT  J.  GRECCO,  USN 

-- 

DESCRIPTION: 

This 

package  implements  the  only 

interfaces  to  -- 

the  parser. 

with  PARSERO,  PARSER_4; 

package  body  PARSER  is 

function  IS_PARSE0  return  boolean  is 

-  pre  -  TOKEN_MATCHER.  SYMBOL_TABLE ,  CODEBLOCKER .  and  NET_GENERATOR  have 
been  initialized. 

--  post  -  If  the  file  being  parsed  is  a  valid  ADA  program,  IS_PARSED 
is  TRUE  else  IS_PARSED  is  FALSE. 

begin 

return  PARSER_0 .COMPILATION : 
exception 

when  PARSER_4.PARSER_ERROR  O 
return  FALSE; 
when  others  => 
raise; 

end  IS_PARSED; 
end  PARSER; 
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TITLE; 


ADAELQW 


--  MODULE  NAME: 

--  EILE  NAME: 

--  DATE  CREATED; 
--  LAST  MODIFIED: 


PACKAGE  PARSERO 
PARSERO.ADS 

18  FEB  88 
28  APR  88 


--  AUrHOR(S):  LT  ALBERT  J.  GRECCO.  USN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY: 

LCOR  JEFFREY  L.  NIEDER,  USN 
LT  KARL  S.  FAIRBANKS,  JR..  USN 
LCDR  PAUL  M.  HERZIG.  USN 


DESCRIPTION:  This  package  defines  the  functions  that 

make  up  the  highest  level  productions  for  a  top-down, 
recursive  descent  parser. 


package  PARSER_0  1s 

function  COMPILATION  return  boolean: 
function  COMP  I  LA  I  ION_UNI T  return  boolean: 
function  CONTExT_CLAUSE  return  boolean: 
function  BASIC_UNIT  return  boolean: 
function  LIBRARY_UNIT  return  boolean: 
function  SUBUNIT  return  boolean: 
end  PARSER_0; 
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TITLE  : 


ADAFLOW 


--  MOOULE  NAME;  PACKAGE  PARSER_0 
--  file  NAME;  PARSERO.AOB 

--  DATE  CREATED:  18  FEB  88 

--  LAST  MODIFIED:  28  APR  88 

--  AUTHOR(S);  LT  ALBERT  J.  GRECCO.  USN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY; 

LCDR  JEFFREY  L.  NIEDER.  USN 
LT  KARL  S.  FAIRBANKS.  JR.,  USN 
LCDR  PAUL  M.  HERZIG,  USN 

DESCRIPTION;  This  package  imp t ements  the  functions  that 
make  up  the  highest  level  productions  for  a  top-down 
recursive  descent  parser.  Each  function  is  preceded 
by  the  grammar  productions  they  are  implementing. 


with  PARSER_1.  PARSER_2,  PARSER_3,  PARS£R_4,  TOK£N_MATCHER; 

package  body  PARSER_0  is 

package  TM  renames  TOKEN_MATCHER . 
package  PI  renames  PARSER_1: 
package  P2  renames  PARSER_2; 
package  P3  renames  PARS£R_3: 
package  P4  renames  PARSER_4; 

--  COMPILATION  -->  [COMPILAriON_UNIT]t 
function  COMPILATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4. OUT_PUI( "COMPILATION" ); 
end  if; 

if  (COMPILATIONUNIT)  then 
while  (COMPILATIONUNIT)  loop 
null; 
end  loop; 
return  (TRUE); 
e  I  se 

return  ( FALSE ) ; 
end  if: 

end  COMPILAIION; 
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--  COMPrLAriON_UNIT  -->  CON  re  XT  CLAUSE  6ASIC_UNIT 
function  COMPILATIONUNIT  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 
P4 .OUT  PUT! "COMPILATION  UNIT”  ) ; 
end  if: 

if  (CONTEXT_CLAUSE )  then 
if  (BASIC_UNIT)  then 
return  (TRUE); 
e  I  se 

return  (FALSE); 
end  i  f ; 
else 

return  (FALSE); 
end  if; 

end  COMPILATIONUNIT; 


--  CONTEXTCLAUSE  [with  WI TH_OR_USE_CLAUSE  [use  UI TH_OR_USE_CLAUSE ]•  ]• 

function  CONTEXT_CLAUSE  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "CONTEXT_CLAUSE" ) ; 
end  if; 

while  (TM.MATCH(TM,T0KEN_WITH))  loop 
if  not  (P2.WITH_OR_USE_CUAUSE)  then 
P4,SYNTAX_ERR0R( "Context  clause"); 
end  if ; 

while  ( TM.MAICH! TM. TOKEN^USE))  loop 
if  not  (P2.W1TH_0R_USE_CLAUSE)  then 
P4 .SYNTAX_ERR0R( "Context  clause" ) ; 
end  if; 

end  loop:  --  inner  while  loop 

end  loop:  --  outer  while  loop 

return  (TRUE); 
end  CONTEXTCLAUSE ; 


--  BASIC_UN[T  -->  LIBRARVUNIT 
-->  SUBUNIT 

function  BASICUNIT  return  boolean  is 
beg  1  n 

if  (P4.PRINT_CALLS)  then 
P4 .OUT  PUT ( "BASIC ^UNI T" ) ; 
end  if; 

if  ( L IBRARY  UNI r  )  then 
return  ( TRUE ) ; 
els  if  (SUBUNIT)  then 
I  e  t u rfi  (TRUE): 
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e  1  se 

return  (FALSE); 
end  if; 

end  BASIC_UNIT; 


--  LIBRARY_UNIT  procedure  PROCEOURE_UNIT 

function  FUNCTIONUNIT 
-->  package  PACKAGE_OECLARATION 
-->  generic  GENERIC_DECLAfiATION 
function  LIBRARYUNIT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("LIBRARY_UNIT" ); 
end  if; 

if  (TM.MATCH(TM.  li..  .  i'KOCEOURE))  then 
if  (PI .PROCEDUREUNIT)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Library  unit"); 
end  if;  --  if  procedure_un i t  statement 
elsif  ( TM.MATCH( TM. TOKEN_fUNCriON) )  then 
if  (P1.FUNCTI0N_UNIT)  then 
return  (TRUE); 
else 

P4  .  SYNTAX_ERROR( "L ibrary  unit"); 
end  If;  --  if  f unct ion_un i t  statement 
elsif  (TM.MATCH(TM, TOKEN_PACkAG£))  then 
if  (P1.PACKAGE_0ECLARATI0N)  then 
return  (TRUE); 
el  se 

P4, SYNTAX_ERROR( "L ibrary  unit"); 
end  if;  --  if  package_dec 1 aration 
elsif  (TM.MATCH(TM.TOKEN_GENERIC))  then 
if  (PI .GENERIC_OECLARATION)  then 
return  (TRUE); 
el  se 

P4 . SYNTAX_ERROR( "Library  unit"); 
end  if;  --  if  generic  declaration 
e  1  se 

return  (FALSE); 
end  if; 

end  library  UNIT; 


--  SUBUNIT  -->  separate  (NAME)  PROPER  BODY 
function  SUBUNIT  return  boolean  is 
beg  1  n 

It  (IM.PHINI  CAI  I  b)  then 
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P4.0UT_PUT( "SUBUNIT" ) ; 
end  1  f  ; 

if  (  rM.MATCH(TM.TOKEN_SEPARATE))  then 
if  (TM.MATCH(TM.TOKEN_LEET_PAREN))  then 
if  (P3.NAME)  then 

if  (TM.MATCH(TM.TOKEN_RIGHT_PAREN))  then 
if  (PI .PROPERBOOY)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( " Subunit" ) ; 
end  if;  --  if  proper_body  statement 
else 

P4.SYNTAX_ERROR( "Subunit"); 
end  if;  --  if  bypass( tokenrightparen ) 
else 

P4.SYMTAX_ERROR("Subunit") ; 
end  if;  --  if  name  statement 
eT  se 

P4 .SYNTAX_ERROR( "Subunit" ) ; 
end  if;  --  if  bypass( token_lef tparen ) 
else 

return  (FALSE); 

end  if;  --  if  bypass( token_separate ) 
end  SUBUNIT; 

end  PARSER_0; 
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TITLE; 


ADAFLOW 


--  MOUULE  NAME:  PACKAGE  PARSER_1 

--  file  NAME:  PARSER  1. ADS 

--  DATE  CREATED:  IS  FEB  88 

--  LAST  MODIFIED:  28  APR  88 

--  AUTHOR(S):  LT  ALBERT  J.  GRECCO,  USN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY; 

LCDR  JEFFREY  L.  NIEDER,  USN 
LT  KARL  S.  FAIRBANKS,  JR.,  USN 
LCDR  PAUL  M.  HERZIG,  USN 

DESCRIPTION;  This  package  defines  the  functions 

that  make  up  the  top  level  productions  for  a  top-down, 
recursive  descent  parser. 


package  PARSER_I  is 

function  GENERIC_OECLARATION  return  boolean; 

function  GENERIC_PARAMETER_DECLARATION  return  boolean; 

function  GENERIC_FORMAL_PART  return  boolean; 

function  PR0CE0URE_UNI T  return  boolean; 

function  SUBPROGRAM_BODY  return  boolean; 

function  FUNCTION_UNI T  return  boolean; 

function  TASK_DECLARATION  return  boolean; 

function  PACKAGE_OECLARAT ION  return  boolean; 

function  PACKAGE_TAIL_END  return  boolean; 

function  DECLARATIVEPART  return  boolean; 

function  BASIC_DECLARATIVE_I TEM  return  boolean; 

function  BASIC_OECLARAriON  return  boolean; 

function  LATERDECLARATIVEI TEM  return  boolean; 

function  PROPERBODY  return  boolean; 

function  SEQUENCEOFSTATEMENTS  return  boolean; 

function  STATEMENT  return  boolean; 

function  COMPOUNOSIATEMENT  return  boolean; 

function  BLOCK  STATEMENT  return  boolean; 

function  IFSTATEMENT  return  boolean; 

function  CASESTATEMENT  return  boolean; 

function  CASE  STATEMENTALTERNATIVE  return  boolean; 

function  LOOPSTATEMENT  return  boolean; 

function  E XCE PT ION  HANOL E R  return  boolean; 

function  ACCEPT  STATEMENT  return  boolean; 

function  SELEC ISTATEMENl  return  boolean; 

Function  SE LEC T  S TATEME N T  T A I L  return  boolean; 
tiinction  SLIICI  AL  ILHNAIIVL  return  boolean; 
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function  SELECT_ENTRY_CALL  return  boolean; 
end  PARS£R_1; 
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TITLE: 


AOAFLOW 


MODULE  NAME: 
FILE  NAME: 

DATE  CREATED: 
LAST  MODIFIED: 


PACKAGE  PARSER_1 
PARSERl.ADB 

18  FEB  38 
28  APR  88 


--  AUTHOR(S):  LT  ALBERT  J.  GRECCO,  USN 


--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY. 

LCDR  JEFFREY  L.  NIEOER,  USN 
LT  KARL  S.  FAIRBANKS,  JR..  USN 
LCDR  PAUL  M.  HER2IG.  USN 


DESCRIPTION:  This  package  implements  the  functions 

that  make  up  the  top  level  productions  for  a  top-down, 
recursive  descent  parser.  Each  function  is  preceded 
by  the  grammar  productions  they  are  implementing. 


with  PARSER_2,  PARSER_3,  PARSER_4, 

TOK£N_MATCH£R.  TOK£N_SCANN£R ,  CODEBLOCKER. 

SYMBOL_TABLE,  NET_G£NERATOR ; 

package  body  PARS£R_1  is 

package  TM  renames  TOK£N_MATCHER; 
package  P2  renames  PARSER_2; 
package  P3  renames  PARSER_3; 
package  P4  renames  PARSER_4: 

IS_MAIN_PROGRAM  :  boolean  TRUE; 

--  GENERIC_DECLARATION  [GENERIC_PARAMETER_DECLARATION  ]• 

GENERIC_FORMAL_PART 

function  GENERIC_DECLARATION  return  boolean  is 
beg  1  n 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT("GENERIC_D£CLARATION"); 
end  if; 

while  (GEN£RIC_PARAMETER_OECLARATION)  loop 
null; 
end  loop; 

if  (GENER1C_F0RMAL_PART)  then 
return( TRUE )  ; 
e  I  se 

return  (FALSE); 
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end  if; 

end  GENERIC_OECLARATION; 


--  GENERIC_PARAMETER_DECLARATION  -->  [DENTIFIER_LIST  :  [MODE  ?]  NAME 

[:=  EXPRESSION  ?]  ; 

-->  type  private  [DISCRIMINANT_PART  ?] 
is  PfiIVATE_TyPE_OECLARATION  ; 

-->  type  private  [DISCRIMINANT_PART  ?] 
is  G£MERIC_ryPE_DEFINITION  ; 

-->  xith  procedure  PROCEDURE_UNIT 
with  function  FUNCTION_UNIT 

function  GENERIC_PARAMETER_DECLARATION  return  boolean  is 
begin 

if  (PA.PRINTCALLS)  then 
P4 .OUT_PUT( "GENERIC_PARAMETER_OECLARAT10N" ) ; 
end  if; 

if  (P2 . IDENTIF IER_LISr)  then 

if  (TM.MATCH(TM.TOXEN_COLON))  then 
if  (P2.M00E)  then 
null  ; 

end  if;  --if  mode  statement 

if  (P3.NAME)  then  --  check  for  type_mark 
if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 
null; 
else 

P4 . syNIAX_ERROR( "Generic  parameter  declaration"); 
end  if;  --  if  expression  statement 

end  if;  --  if  match{ token_ass ignment ) 

if  (TM.MArCH(lM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . syNTAX_ERROR( “Gener 1C  parameter  declaration"); 
end  if;  --  if  match( tokensemicol on ) 

e  Ise 

P4 . SyN rAX_ERROR( "Gener  1C  parameter  declaration"); 
end  if;  --  if  typemark  statement 

else 

P4 . SyNTAX_ERROR( "Gener 1C  parameter  declaration"); 
end  if;  --  if  match( tokencoion ) 

elsif  (TM.MATCH(TM.TOXEN_ryPE))  then 
if  {TM.MATCH(TM. TOKEN  IDENTIFIER))  then 
if  (P2.DISCRIMINANT_PART)  then 
null  ; 

end  if;  --  if  discriminanlpart 

if  ( TM.MATCH( TM. TOKENIS) )  then 
If  (P2.PRIVATf_lyPE_0ECLARATI0N)  then 
if  ( TM.MATCH( TM. TOKEN  SEMICOLON) )  then 
return  (  IRUi  )  , 
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e1  se 

P4 .SYNTA)(_ERROR( "Generic  parameter  declaration"); 
end  if;  --  if  match( token_semicolon ) 

elsif  (P2.GENERIC_TYPE_0EFIN1TI0N)  then 
if  (TM.MATCH(TM.T0KEM_SEMIC0LQN))  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic  parameter  declaration"); 
end  if;  --  if  match( tolten_semicolon ) 

else 

P4 .SYMTAX_ERROR( "Generic  parameter  declaration*); 
end  if;  --  if  pr1wate_type_declaration 

else 

P4 . SYMTAX_EHROH( "Generic  parameter  declaration*); 
end  if;  --  if  match( tolten_is ) 

else 

P4 .SYMTAX_ERROft( "Generic  parameter  declaration’); 
end  if;  --  if  matcn( tokenident i f ier ) 

elsif  (TM.MATCH(TM.TOKEN_WITH))  then 
if  (TM.MATCH(TM.TOKEN_PROCEDURE))  then 
if  (PROCEOURE_UNIT)  then 
return  (TRUE); 
el  se 

P4 . SYNTAX^ERROR( “Generic  parameter  declaration"); 
end  if;  --  if  procedure_unit  statement 

elsif  (TM.MATCH( TM. TOXEN_FUNCTION))  then 
if  (FUNCnON.UNIT)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R("Generic  parameter  declaration"); 
end  if;  --  if  f unct ion_un i t  statement 

else 

P4 .SYNrAX_ERROR( "Generic  parameter  declaration"); 
end  if;  --  if  match( token_procedure ) 

else 

return  (FALSE); 

end  if;  --  if  ident i f ierl i st 

end  GENERIC  PARAME rEH_OECLARA 1  ION; 


--  GtNERIC_FORMAL_PART  -->  procedure  PROCEOURE_UNn 
-->  function  FUNCTI0N_UN1T 
-->  package  PACKA6£_0£CLARAT10N 
function  GENER1C_F0RMAL_PART  return  boolean  is 
beg  in 

if  (P4.PRINT_CALLS)  then 

P4  OUl  PUT( "GENERIC_FORMAL  PART"  )  ; 
end  if; 

if  ( fM.MArCH( TM. TOKEN  PROCEDURE  ))  then 
if  (PROCroiJRt  UNIT)  then 
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return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic  formal  part"); 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_FUNCTION))  then 
if  (FUNCTION_UNIT)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR( "Generic  formal  part"): 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_PACKAGE))  then 
if  (PACKAGE_OECLARATION)  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic  formal  part"); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  GENERIC_FORMAL  PART; 


if  procedure_unit  statement 


if  function  unit  statement 


if  paclcage_declaration 


--  PROCEDURE_UNIT  -->  identifier  [FORMAL_PART  ?]  is  SUBPROGRAM_BODY 
-->  identifier  [FORMAL_PART  ?]  ; 

-->  identifier  [FORMAL_PART  ?]  renames  NAME  ; 
function  PROCEOURE_UNI T  return  boolean  is 
START_TOKEN  ;  TOXEN_SCANNER . T0KeN_R£C0R0_TYPE ; 

LOCATION  :  natural; 
begin 

if  (P4.PRINT_CALLS)  then 

P4 ,0UT_PUT( "PROCEOURE_UNIT" ) ; 
end  if; 

if  (TM,MATCH(TM.TOKEN_IDENTIFIER))  then 
TM .MATCHEO_TOXEN( START_TOKEN ) ; 

COOE_BLOCXER.ENTER_COOE_BLOCK(START_TOKEN. SOURCE,  "PROCEDURE  CODE  BLOCK"); 
CODE_BLOCKER. INCREMENTSTATEMENTCOUNT; 

LOCATION  ;=  C00E_8L0CKER . CURR£NT_CODE_BLOCK_NUM8E R ; 

SYM80L_TA8LE. INSERT_SYM_TA8(STAflT_T0KEN.LEXEME( 1. .STARTTOXEN . LEXEMESIZE ) . 

SYMBOLTABLE . PROCEOURE_DECLARATION_TAG , 
LOCATION); 

SYMBOL_fABLE. INSERT  SYM_TAB( "END",  SYMBOL_rABLE . LABEL_NAME .  0); 
if  ( IS_MAIN_PROGRAM)  then 

NET  GENERATOR . START( SYMB0L_TA8LE . F IN0_KEY( START  TOKEN . LEXEME( 1 .  . 

START  TOKEN.LEXEME  SIZE ) ) ) ; 

IS_MAIN_PROGRAM  ;=  FALSE; 
end  i  f ; 

if  (P2. FORMAL  PART)  then 
null; 

end  if;  -*  if  formal  part  statement 

if  ( TM.MAIC H( iM . lUKtN  IS) )  then 
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if  ( SUBPR0GRAM_80DY )  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Procedure  unit"); 

end  if;  --  if  subprogram  body  statement 

elsif  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
COOE_8LOCKER.OELETE_CQOE_BLOCK_ENT£R; 

SYMBOt_ TABLE . EXI T_SCOPE ; 

SYMBOL_TABLE .UPOATE_SYM_TAB(0); 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_R£NAMES))  then 
COOE_BLOCKER.DELETE_CODE_BLOCX_ENTER; 

SYMBOL_TABLE .EXI T_SC0PE ; 

SYKtBOL_TABLE  .  UP0ATE_SYM_TA8(  0 ) ; 
if  (P3.NAME)  then 

if  (TM.MATCH(TM.TOK£N_SEMICOLON))  then 
return  (TRUE); 
else 


P4 . SYNTAX_ERROR( "Procedure  unit"); 
end  if; 
else 

P4 . SYMTAX_ERROR( "Procedure  uni t"  ) ; 
end  if; 
end  if; 
else 

return  (FALSE); 
end  if; 

end  PROCEDURE_UNIT; 


if  match( tokensemi colon ) 


if  name  statement 
if  match(token_is) 


if  match( token_ident i f ier ) 


--  SUBPROGRAMBODY  -->  new  NAME  [GENERIC_ACTUAL_PART  ?]  ; 

-■•>  separate  ; 

-->  <>  ; 

-->  [DECLARATIVE_PART  7]  [begin  SE0UENCE_OF_STATEMENTS 
[exception  [EXCEPTION_HANDLER]+  ?]?]  end  [DESIGNATOR  ?]  ; 
-->  NAME  ; 

function  SUBPROGRAMBODY  return  boolean  is 
STARTTOKEN  :  TOKENSCANNER . TOkENRECOROTYPE ; 

STOP_TOKEN  :  TOKENSCANNER . TOKENRECOROTYPE ; 

LOCATIOMONE  :  natural; 

LOCATIONTWO  :  natural; 
use  SYMBOL  TABLE; 


beg  i  n 

if  (P4.PRIMT_CALLS)  then 

P4 .0UT_PUT( "SUBPROGRAMBODY" ) ; 
end  if; 


LOCATION  ONE  :=  CODEBLOCKER.CURRENI  CODE  BLOCK  NUMBER; 
if  ( rM,MATCH( TM. TOKENNEW) )  then 
CODE  BLOCKER.OEIETECOOE  BLOCK  ENTER; 

SYMBOL  TABI  E  .EXI  I  SCOPE ; 
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SYMBOL_TABLE .UPDATE_SYM_rAB(0) ; 
if  (P3.NAME)  then 

if  (P2.GENERIC_ACTUAL_PART)  then 
null; 

end  if;  --  if  generic  actual  part 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
el  se 

P4 . SYNTAX  ERROR ( "Subprogram  body"  ) ; 
end  if;  --  if  (natch( token_se(nicolon ) 

else 

P4 . SYNTAX_ERROR( "Subprogram  body " ) ; 
end  if;  --  if  name  statement 

elsif  (TM.MATCH(TM.TOKEN_SEPARATE) )  then 
CODE_BLOCKER.DELETE_CODE_BLOCK_ENTER; 

SYMBOL_TABLE . EXIT_SCQPE ; 

SYMBOL_TABLE . UPOA  TE_SYM_TAB( 0 ) ; 
if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Subprogram  body " ) ; 
end  if;  --  if  match( tolien_semicol on ) 

elsif  (TM.MATCH(TM.TOKEN_BRACKETS))  then 
CODE_BLOCKER . DELETE_COD£_BLOCK_ENTER ; 

SYMBOL_TABLE . EXIT_SCOPE ; 

SYM80L_TABLE . UPOATE_SYM_TAB( 0 ) ; 
if  (TM.MATCH(TM.TOKEN_SEMICOLON) )  then 
return  (TRUE); 
el  se 

P4 ,SYNTAX_ERfiOR( "Subprogram  body" ) ; 
end  if;  --  if  match( token_semicol on ) 

elsif  {DECLARAT[VE_PART)  then 

LOCATION_ONE  ;=  CODE  BLOCKER. CURRENT  C00E_8L0CK_NUMBER; 
if  (TM,MATCH(TM,TOKEN_BEGIN))  then 
TM.MATCHeO_TOK£N(START_TOK£N); 

CODE_BLOCKER.ENTER_COOE_BLOCK(START_TOKEN. SOURCE.  "BEGIN  SUBPROGRAM") ; 
C00E_BL0CKER . INCREMENTSTATEMENTCOUNT ; 

LOCATIONTWO  ;=  COOE_BLOCKER . CURRENTCODEBLOCKNUMBE R ; 

NETGENERATOR . C0NNECT_BL0CKS( LOCATIONONE .  LOCATIONTWO ) ; 
if  (SEQUENCEOFSTATEMENTS)  then 

if  (COOE_BLOCKER.CURRENT_STATEMENT  COUNT  =  0)  then 
LOCATION  ONE  ; =  0; 

CODE_BLOCKER.DELETE_COOE_BLOCK  ENTER; 
else 

TM.MATCH£D_TOKEN(STOP_TOKEN) ; 

LOCATION_ONE  CODE_aLOCKER . CURRENT_COOE_SLOCK_NUMBER ; 

CODE  BLOCKER.EXIT_COOEBLOCK( STOP  TOKEN, SOURCE); 
end  if; 

if  ( IM.MATCH( TM. TOKENEXCEPriON) )  then 
if  (EXCEPTION  HANDLER)  then 
while  (EXCEPflONHANDLER)  loop 
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nul  1 ; 
end  loop; 
else 


P4.SYNTAX_ERR0ft( "Subprogram  body"); 

"■  if  exception  handler  statement 
■■  if  matcft(  tokenexcept  ion ) 

else 

P4.SYNTAX_ERR0R( "Subprogram  body" ) ; 

--  if  sequence  of  statements 
if'  --  if  token  begin 

if  (TM.MArCH(TM.TOKEN_ENO))  then 
TM . MATCHE0_T0KEN( SrOP_TOKEN ) ; 

CODE_BLOCKER.ENTER_COD£_BLOCK(STOP_TOKEM. SOURCE .  "END  SUBPROGRAM" ) ; 
COOE_8LOCKER. INCREMENT_STATEMENT_COUNT; 

LOCATION_TWO  ;=  COOE_aLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
if  (SYMB0L_TABLE.FIND_L0CAL_KEY("END")  =  null)  then 
raise  SYMB0L_TABLE.REFERENCE_ERR0R; 
else 

SYMB0L_TABLE.UP0ATE  SYM_rAB(tOCATION_TWO) : 
end  if; 

if  (LOCAflONONE  =  0)  then 
NET_GENERATOR.EXPLtCIT_ENQ(LOCATIQN_TWO); 
else 


NET_6ENERATOR.CONN£CT_BLOCKS(LOCATION_ONE,  LOCATION_TWO); 
end  if; 

C0DE_BL0CkER . EX  I T  COOE  BLQCK( ST0P_T0KEN . SOURCE ) ; 
if  (P2. DESIGNATOR)  then 
null; 


■'  if  designator  statement 
if  (rM.MATCH(TM.T0KEN_SEMIC0L0N))  then 
C00E_BL0CXER . EX  I r_C00E_8L0CK( STOP_TOKEN . SOURCE ) ; 
SYM80L_TA8LF .EXIT_SC0P£ : 
return  (TRUE); 
e  I  se 


P4. SYN T AX _ERR0R(" Subprog  ram  body"); 
end  if;  --if 

e  I  se 


match ( token  semi col  on ) 


P4.SYNrAX_ERR0R{"Si'bpfogram  body"); 

■■  if  match(  token  end ) 

elsif  ' TM.MArCH( TM.TOkEN_BfGIN))  then 
TM  .MATCHEO_TOI(EN(STARr_TOXEN) ; 

LOCAIION^ONE  ;=  CODE  BLOCKER  CURRENT _COOE _8L0CK_NUMBtR ; 

CODE _BLOCKER.ENTER_COOE_8LOCK(START_TOKEN. SOURCE.  "BEGIN  SUBPROGRAM”); 
LOCATION  TWO  :=  COOEBLOCKER , CURRENTCODE  BLOCK  NUMBER; 

NE  TGENERATOR.  CONNECT  _BLOC:;S(  LOCATION  ONE.  LOCATIONTWO) ; 
if  (SEOUENCEOF  STATEMENTS)  then 

If  (COOE_BLOCKER. CURRENT  STATEMENTCOUNT  -  0)  then 
LOCATION  ONE  : =  0; 

CODEBLOCKER  DELETE  COOEBLOCKENTER; 
e  I  se 

rM.MAICHID  rOKLN(SIOP  lOKEN). 
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LOCATION  ONE  CODE_BLOCKE R . CURRENT  CODE _8L0CK_NUMBE R ; 

CODE_BLOCKER , EX  I T  _CODE_BLOCK( STOP^TOKEN . SOURCE ) : 
end  1  f ; 

if  (TM.MATCH(TM. rOKEN_EXCEPTION))  tnen 
if  (EXCEPTIONHANDLER)  then 
while  (EXCEPTION_HANDLER)  loop 
null; 
end  loop; 
e  1  se 

P4.SYNTAXERR0R( "Subprogram  body" ) ; 
end  if;  --  if  e)iception_handler  statement 

end  if;  -■  if  match( token_except ion  ) 

e  1  se 

P4.SYNTAX_ERROR( "Subprogram  body"); 
end  if;  --  if  sequence  of  statements 

If  ( TM.MATCH( TM. TOKENENO) )  then 
TM.MATCHED_TOKEN(STOP_TOKEN) ; 

COOE_BLOCXER . ENTERCODEBLOCKl STOPTOKEN . SOURCE ,  "END  SUBPROGRAM" ) ; 

CODE  BLOC XE R . I NCREMEN TSTA TEMEN T  COUNT ; 

LOCATION  TWO  CODE  BLOCKE R . CURRENT_CODE_BLOCK_NUMBER ; 
if  (SYMBOLTABLE . FIND_LOCAL_KEY( "END" )  -  null)  then 
raise  SYMBOL^TABLE . R£F£RENC£_ERROR; 
e  1  se 

SYMBOL_TA8L£ .UPOAT£_SYM_TAB(LOCAT10N,TWO) ; 
end  if; 

if  (LOCATION_ON£  =  0)  then 
N£T_G£N£RATOR. EXPLICI T_EN0(L0CAT10N_1W0) ; 
e  1  se 

N£T_G£N£RA TOR. CONNECT  BLOCKS) LOCATION  ONE .  LOCA T ION_TWO ) ; 
end  if; 

COO£_8LOCK£R. tXlT_CODE_BLOCK{STOP_IOKEN.SOURCE ); 
if  {PE.DESIGNAIOR)  then 
nul  I  ; 

end  if;  --  if  designator  statement 

if  (TM.MATCH(TM.TOK£N_S£MICOLON))  then 
CODE  BLOCKER  EX  I T  COOE  BLOCK) STOP_  TOKEN . SOURCE ) ; 

SYMBOL  TABLE . EXI TSCOPE ; 
return  ( TRUE  )  ; 
else 

P4 . SYNTAX  ERROR) "Subprogram  body" ) ; 
end  if.  '  It  ina  t  ch  (  lokensem  1  CO  1  on  ) 

e  I  se 

P4.SYNIAX  L HROR ) "Subp rog ram  body"); 
end  if;  if  ma tch) token  end ) 

elsit  (  IM.MAlCtl)  IM.  TOKEN  ENU))  then 
IM.MAICHLO  IOKtN)SIOP_TOKEN); 

COIIF  Bl  OCKER  .  ENTER  COOE  BLOCK )  SIOP_  TOKEN  .  SOUHCT  .  "END  SUBPROGRAM"  )  , 
com  BIOCKER.  INCREMENT  STA  TEMEN  T  COUN  T  ; 

LOCA  MON  TWO  CODE  BLOCKER. CURRENT  COUE  BLOCK  NUMBER; 

If  (SYMBOL  TAHIE.FINO  I OCAl  KEY) "END" )  -  rull)  then 
lai'.e  SiMBOl  I  ABI  1  K!  1  1  111  NCI  IRHOR; 
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e  1  se 


SYMBOL  TABLE  .UPDATE_SYM_TAB(LOCAnON_TWO); 
end  if; 

N£r_GEN£RATOH.CONNECT_BLOCKS(LOCATION_ONE,  LOCAT ION_TWO ) ; 
CODE_BLOCKER . EX  I T_CODE_BLOCK{ STOP_TOKEN . SOURCE ) ; 
if  (P2. DESIGNATOR)  then 
null; 

end  if;  --  if  designator  statement 

if  (TM.MATCH(TM.T0KEN_SEMIC0L0N))  then 
CODEBLOCKER . EXl T_COO£_BLOCK(STOP_TOKEM . SOURCE ) ; 

SYMBOL_TABLE . E  X I TSCOPE ; 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( ” Subprogram  body"  ) ; 
end  if;  --  if  match(toKen_semicolon) 

elsif  (P3.NAME)  then 

COOE_8LOCKER.OEL£TE_CODE_BLOCK_£NrER; 

SYMBOL_TABLE .EXI TSCOPE ; 

SYMBOL_TABLE .UPDAT£_SYM_TAB(0); 
if  (TM.MATCH(TM.T0K£N_SEMIC0L0N))  then 
return  ( TRUE  )  ; 
el  se 

P4  .  SYNTAX_ERROR( "Subprogram  body"  ) ; 
end  if;  --  if  match( token_semicolon ) 

e  1  se 

return  (FALSE): 

end  if;  --  if  match( token_new) 

end  SUBPROGRAM  BODY  ; 


-■  FUNCTI0N_UN1T  ■•>  DESIGNATOR  [fORMAL^PART  ?]  return  NAME  is 

SUBPROGRAMBODY 

-->  DESIGNATOR  [FORMAL_PART  ?]  return  NAME  ; 

DESIGNATOR  [FORMAL_PART  ?]  return  NAME  renames  NAME  ; 

-  >  DESIGNATOR  is  SUBPROGRAM  BODY 
(for  generic  instantiation) 
function  FUNCTIONUNIt  return  boolean  is 
START_ TOKEN  :  TOKEN^SCANNER . TOK£N_RECORO_TYPE ; 

LOCA T ION  :  nature  1 ; 
beg  1  n 

if  ( P4 .PHINTCALL S)  then 

P4 ,0UT_PUT( "FUNCTION  UNI T" ) ; 
end  if; 

if  (P2. DESIGNATOR)  then 

TM  MATCHED  rOKEN(START_rOKEN); 

CODE  BLOCKER. ENTER  CODE_BLOCK(SIART  TOKEN. SOURCE.  "FUNCTION  CODE  BLOCK"); 
CODE  BLOCKER. INCREMENTSTATEMENTCOUNT ; 

LOCATION  :=  CODE  BLOCKE R . CURREN r_COOE_BLOCK_NUMBER ; 

SYMBOL  TABLE .INSERT  SYM  I AB( STAR T  TOKEN . LE XEME ( 1 .  . ST AR T  TOKE N . L E XEME  S I  EE ) , 

SYMBOl  T  ABL  L  .  F  TINE  T  I  ON  DT  Cl  APA  T  I  ON  I  AG  , 
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LOCAriON); 

SYMBOL_TABLE.INSERT_SYM_TAB(”END*,  SYMBOL_TABLE . LABE L_NAM£ .  0); 
if  ( IS_MAIN_PROGRAM)  then 

NE  T  GENERATOR . START( SYMBOL  TABLE . F I MO_K£Y( STARE  IOKEN . LEXEME ( 1 . . 

START_TOICEN .  LEXEME_SIZ£  )  > ) 

IS_MAIN_PROGRAM  :=  FALSE: 
end  if; 

if  ( P2. FORMAL_PARr)  then 

if  (TM.MATCH(TM.TOKEN_RETURN))  then 
if  (P3.NAME)  then 

if  (TM.MATCH(TM.TOKEN_IS))  then 
if  (SUBPROGRAM_BOOY)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR( "Function  unit"); 
end  if; 

elsif  (TM.MATCH(rM.TOKEN_SEMICOLON))  then 
COO£_BLOCKER.O£LEVE_COOE_BLOCK_£«T£R; 

SYMBOL_TABLE .£XIT_SC0PE; 

SYMBOL, TABLE . UPOA  TE_SYM_TAB( 0 ) ; 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_RENAM£S))  then 
COOE_BLOCKER.O£LET£_COO£_BLOCK_ENTER; 

SYMBOL_TABLE.EXIT_SCOPE; 

SYMBOL_rABLE . UPDATE_SYM_TAB( 0 ) ; 
if  (P3.NAME)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR(" Function  unit"); 
end  if; 
else 

P4 . SYNTAX_ERROR( "Function  unit"); 
end  if; 
else 

P4.SYNTAX_ERROR(" Function  unit"); 
end  i  f ; 
else 

P4. SYNTAX _ERROR( "Function  unit"); 
end  if; 

elsif  (TM.MATCH{TM.TOKEN_RETURN))  then 
If  (P3.NAME)  then 

if  (  TM.MATCH(TM.  TOKEN  JS)  )  then 
if  (SUBPROGRAM  BODY)  then 
return  ( TRUE )  ; 
e  I  se 

P4.SYNrAX_£HROR( "Function  unit"); 
end  if; 

elsif  ( TM,MATCH( TM. TOKEN  SEMICOLON) )  then 
CODE  BLOCKER. DELETE  CODE  BLOCK, ENTER; 

SYMBOL  TABLE. INSERT  SYM  rA8("EN0".  SYMBOL  I ABl  E .  I  ABE L  NAME,  0); 
SYMBOL  lABLE .EXIT  SCOPE ; 
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SYMBOLTABLE . UPDATE_SYM_TAB( 0 ) ; 
return  (TRUE); 

elsif  (TM.MATCH(TM,TOKEN_REMAMES))  then 
CODE  BLOCKER, DELETE_COOE_BLOCK_ENTER; 
SYMBOLTABLE.EXITSCOPE; 

SYMBOLTABLE . UPDATE_SYM_rAB( 0 ) ; 
if  (P3,NAM£)  then 
return  (TRUE): 
else 

P4 . SYNTAX_ERROR( "Function  unit”); 
end  if; 
el  se 

P4 , SYNTAX_ERROR( "Function  unit"); 
end  if; 
else 

P4 . SYNTAX_ERROR( "Function  unit"); 
end  if; 
e  1  se 

P4.SYNTAX_ERR0R( "Function  unit"  ) ; 
end  if; 

elsif  (TM.MATCH(TM.TOK£n_IS))  then 
if  (SU8PROGRAM_BODY)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Function  unit"); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  FUNCTION  UNIT; 


--  TASKOECLARATION  tody  identifier  is  SUBPR0GRAM_B0DY  ; 

-->  [type  ?]  identifier  [is  [ENTRY_DECLARATION]* 

[REPRESENrAriON_CLAUSE]*  end  [identifier  ?]  ?]  ; 
function  TASK_OECLARATION  return  boolean  is 
START_rOKEN  :  TOKEN^SCANNE R , rOKEN_R£CORO_ TYPE ; 

LOCATION  :  natural  ; 
beg  in 

if  ( P4 .PRINT_CALLS)  then 

P4 .0UT_PUT( "TASKOECLARATION" ) ; 
end  if; 

if  ( rM.MATCH( TM. TOKENTYPE ) )  then 
null; 

end  if;  -  if  inatch{  tokentype ) 

if  ( TM. MATCH! TM. TOKENBODY ) )  then 

if  (TM.MArCH(rM. TOKEN  IDENTIFIER))  then 
IM.MATCHEO_TOKEN(START_TOKEN); 

LOUE  BLOCKER. ENTER  CODE  BLOCK(SIAHIIOKtN. SOURCE.  "TASK  CODE  BLOCK"); 
rODl  HI  OCKTH.  INCREMENI  STATEMENI  COON  i  : 
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LOCATION  :=  C0DE_8L0CKER . CURfi£NT_CODE_BLOCK_NUMB£R; 

SYMBOLTABLE . INSERT  SYM_TAB( STARTTOKEN . LEXEME( 1 . . STARTTOKEN . 

LEXEMESIZE),  SYMBOL_TABLE . TASK_BODY_TAG , 
LOCATION); 

if  (TM.MATCH(TM.TOKENJS))  then 
If  (SUBPROGRAM_BODY )  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package  declaration"); 
end  If;  --  if  subprogram  body 

else 

PA . SYNTAX_£RROR( "Package  declaration"); 
end  if;  --  if  token  is 

else 

PA .SYNTAX_ERROR( "Package  declaration"); 
end  if;  --  if  token  identifier 

elsif  (TM,MATCH(TM.TOKEN_ID£NTIfI£R))  then 
TM,MATCH£D^T0K£N(START_T0KEN) ; 

SYMBOL_TABLE . INSERT_SYM_TA8( START  TOKEN . LEXEME( 1 . .STARTTOKEN . 

LEXEMESIZE), 

SYM80L_TABLE . TASK  DECLARAT I0N_TAG ,  0  ) ; 
SYMBOL_TABLE.INSERT_SYM_TAB("£ND",  SYMBOL  TABLE. LABEL_NAME,  0); 
NET_GENERATOR. START(SYMBOL_TABLE.F IN0_KEY( START_TOKEM. LEXEME ( 1 . . 

START_TOXEN.LEXEME_SIZE) )) 

if  (TM  MATCH(TM.TOKEN_IS))  then 
while  (P2 .ENTRY_QECLARATION)  loop 
null; 
end  loop; 

while  (P2.REPRES£NTATI0N_CLAUSE)  loop 
null; 
end  loop; 

if  (TM.MATCH(TM.T0KEN_END))  then 

if  (TM,MATCH(TM,T0KEN_IDENTIF1ER))  then 
null; 

end  if;  --  if  (natch(  tokenident  i  f  ler ) 

if  (TM.MATCH(TM.T0KEN_SEMIC0L0N))  then 
SYMBOL_TABLE.EXIT_SCOPE; 
return  (TRUE); 
el  se 

PA . Si NTAX_ERROR( "Task  dec  1  a ra t ion” ) ; 
end  if;  -  if  match ( tokensem i co 1  on  ) 

e  I  se 

PA  SYNTAX  JRROR(  "Task  dec  la  rat  ion")  ; 
end  if;  --  if  match( tokenend ) 

elsif  ( TM.MATCH( TM. TOKEN  SEMICOLON) )  then 
SYMBOL  1  ABLE  .  E XI T  SCOPE ; 
return  ( TRUE  )  ; 
e  I  se 

PA.SYNrAX_ERROR(''Iask  declaration"); 
end  if;  if  ma tch( tok en  i s ) 
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--  if  matcli( token_body ) 


return  (FALSE); 
end  i  f ; 

end  TASK_DECLARATION; 


--  PACKAGEDECLARATION  -->  body  identifier  is  SUBPROGRAMBODY 
-->  identifier  is  PACKA6E_TAIL_EN0 
'->  identifier  renames  NAME; 
function  PACKAGEDECLARATION  return  boolean  is 
START_TOKEM  ;  TOKEN_SCAMNER . TOKEM_R£CORO_TYP£ ; 

LOCATION  :  natural ; 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .0UT_PUT( "PACKAG£_DECLARATION" ) ; 
end  if; 

if  (TM.MATCH(TM.T0KEN_B00Y))  then 

if  (TM.MATCH(TM.TOKEN_IOENTIfIER))  then 
rM.MATCHEO_TOKEN(START_TOKEN) ; 

C0DE_8L0CKER.£NTER_C00£_BL0CK(START_T0KEN. SOURCE,  "PACKAGE  CODE  BLOCK"); 
C0DE_8L0CKER. INCREM£NT_STATEMENT_COUNT; 

LOCATION  :=  C0DE_8L0CKER.CURRENT_C0D£_BL0CK_NUMBER; 

SYMBOL_TABL£. INS£RT_SYM_TAB(START_TOKEN.LEXEME( 1. . START_TOKEN . 

LEXEME_SI ZE ) .  SYMBOL_TABLE . PACKAGE_BODY_TAG , 
LOCATION); 

if  (TM.MATCH(TM.TOKEN_IS))  then 
if  (SUBPR0GRAM_B00Y)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package  dec  la  rat  ion" ) ; 
end  if;  --if  subprogram  body 

el  se 

P4 . SYNTAX_ERROR( "Package  declaration"); 
end  if;  --if  token  is 

else 

P4. SYNTAX _ERROR( "Package  declaration"); 
end  if;  -  'f  token  identifier 

elsif  ( TM.MATCH( TM, T0KEN_1DENTIFIER) )  then 
rM.MATCHEO_TOKEN(START_TOKEN); 
if  (TM.MATCH(TM.T0KEN_1S))  then 

SYMB0L_TABL£ , I NSERT_SYM_TAB( STAR T_ TOKEN . LEXEME ( 1 . , STARTTOKEN . 

LEXEME_SIZE ) . 

SYM80L_TA8LE . PACKAGE_DECLARAT I0N_TAG ,  0 ) ; 
SYMB0L_TA8LE.INSERT_SYM_TAB("EN0",  SYMBOLTABLE.LABELNAME,  0); 
if  (PACKAGE_TAIL_END)  then 
return  (TRUE); 
e  I  se 

P4 . SYNIAX_ERROR( "Package  declaration"); 
end  if;  -■  'f  packageta i 1  end 

elsif  ( TM. MATCH) TM. TOKEN  RENAMES) )  then 
if  (P3.NAMi  )  then 
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if  ( TM.MATCH( TM.  TOKEN  SEMICQLON) )  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package  declaration"); 
end  if;  --  if  token  semicolon 

else 

P4 . SYNTAX_ERROR( "Package  declaration"); 
end  if;  --  if  name 

else 

P4 .SYNTAX_ERROR( "Package  dec  1  a  rat  ion" ) ; 
end  if;  --  if  token  identifier 

else 

return  (FALSE); 

end  if;  --  if  match( tokenpackage ) 

end  PACKAGE_DECLARATION; 


--  PACKAGE_TAIL_END  -->  new  NAME  [GENERIC_ACTUAL_PART  ?]  ; 

-->  [BASIC_DECLARATIV£_ITEM]«  [private 

[BASIC_OECLARATIVE_ITEM]»  ?]  end  [identifier  ?]  ; 
function  PACkAGE_TAlL_ENO  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT( "PACKAGE_TAIL_EN0" ) ; 
end  if; 

if  ( rM.MATCH( TM. T0KEN_NEW) )  then 
if  (P3.NAME)  then 

if  (P2.GEN£RIC_ACruAL_PARr)  then 
null; 

end  if;  -•  if  generic_actual_part  statement 

if  (TM. MATCH) TM. TOKEN_SEMICOLON))  then 
SYMBOL_TABL£.EXIT_SCOPE; 
return  (TRUE); 
e  1  se 

P4 . SYN IAX_ERROR( "Package  tail  end"); 
end  if.  --  if  match) tokensem i col  on ) 

e  I  se 

P4.SYNTAX  ERROR) "Package  tail  end"); 
end  if;  if  name  statement 

eisif  (BAS1C_DECLARAT1VE_ITEM)  then 
while  (BASIC_0ECLARATIVE  ITEM)  loop 
nul  1  ; 
end  loop; 

if  ( TM. MATCH) TM. TOKEN_PRIVATE ) )  then 
while  (BASIC_DECLARATIV£_ITEM)  loop 
null; 
end  loop; 

end  if;  if  match) token  private  ) 

If  (  IM.MAICIU  IM. TdkEN  ENO) )  then 

il  ( IM . MA ICH) TM ,  TOKEN  IDENIIilER))  then 
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null  ; 
end  If; 

if  (TM.MATCH( TM.TOKEN_SEMICOLON) )  then 
SYMBOL_TABLE . EXITSCOPE ; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Package  tail  end"); 
end  if;  --  if  inatch(  tokensemicol  on  ) 

else 

P4 . SYNTAX_ERROR( "Package  tail  end"); 
end  if;  --  if  match( token_end ) 

elsif  (TM.MATCH(TM.TOKEN_PRIVArE))  then 
while  (BASIC_DECLARATIVE_ITEM)  loop 
null; 
end  loop; 

if  (  TM.MATCH( TM. TOKEN  ENO) )  then 

if  ( TM.MATCH( TM. TOKEN_IDENTIFIER) )  then 
null  ; 
end  if; 

if  (TM.HATCH(TM.TOk£N_S£MICOLON))  then 
SYMBOLTABLE .EXITSCOPE; 
return  (TRUE); 
else 

P4 . SYNTAX_£RROR( "Package  tail  end"); 
end  if;  --  if  niatch( token_semicol on ) 

else 

P4 . SYNTAX_£RROR( "Package  tail  end"); 
end  if;  --  if  iTiatch(  tokenend ) 

elsif  (TM  MATCH(TM.TOKEN_ENO))  then 

if  (TM.MATCH( TM. TOKEN  IDENTIFIER) )  then 
null  ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
SYMBOL_TABLE . EX  I T_SCOPE ; 
return  (TRUE); 
else 

P4 . SYNTAX  ERROR( "Package  tail  end"); 
end  if;  if  malch( loken  semi co 1  on ) 

else 

return  ( FALSE  ) ; 

end  if;  if  malch( tokennew ) 

end  PACKAGE  TAIl  END; 


BASIC_0EC1  ARAIlVE  llEM  ->  BASIC_OECLARAI IVE 

-  >  REPRESENTATION  CLAUSE 
>  use  with  OR  USE  CLAUSE 
function  BASIC  OE C 1  AHA M VE  I  I E M  return  boolean  is 
beg  1  n 

It  (  IM  .  PRl  N  f  f  Al  1  S  I  I  nun 
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P4.0UT_PUT('’BASIC_0ECLARATIVE_ITEM"); 
end  i f ; 

if  (BASIC_DECLARAriON)  then 
return  (TRUE); 

elsif  (P2.REPRESENTATI0N_CLAUSE)  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_USE))  then 
if  (P2.WITH_0R_USE_CLAUSE)  then 
return  (TRUE); 
else 

P4 . SyNTAX_ERROR( "Bas ic  declarative  item"); 
end  if; 
e  1  se 

return  (FALSE); 
end  if; 

end  BASIC_DECLARATIVE_IT£M; 


--  QECLARATIVE_PART-->  [BASIC_0ECLARAT1VE_ITEM]*  [LATER_OECLARATIVE_nEM]* 
function  DECLARATI VEPART  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( “D£CLARATIVE_PART' ) ; 
end  if; 

while  (BASIC_DECLARATIV£_ITEM)  loop 
null; 
end  loop; 

while  (LA’'ER_D£CLARATIVE_ITEM)  loop 
null; 
end  loop; 
return  (TRUE); 
end  OECLARATIVEPART ; 


■-  BASIC_DECLARAnON 

--> 
--> 
--> 

-> 
> 

--> 
-  -> 

function  BASIC  DECLARAIION 


type  ryPEDECLARATION 
subtype  SUBTyPEDECLARAT ION 
procedure  PROCEOURE_UNI T 
function  fUNCTION_UNIT 
package  PACKAGE_OECLARATION 
generic  GENERIC_DECLARAT10N 
lOENTIFIERDECLARATION 
task  TASKOECLARATION 
return  boolean  is 


beg  1  n 

if  ( P4  ,  PRINl  CALLS)  then 

P4  OUl  PUT( "BASIC  OECLARA! ION" ) ; 
end  if; 


1 f  (  IM.MAICH) 
It  (  P2 . lyPI 


IM . TOKEN  TYPT  ) )  then 
IIKLAKAriON)  then 
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return  (TRUE); 
else 

P4.S^NTAX_ERR0R( "Basic  declaration”) 
end  if; 

elsif  ( TM.MATCH( TM. TOKEN  SUBTYPE))  then 
If  (P2.SUBTyPE_D£CLARATI0N)  then 
return  (TRUE); 
else 

P4.SyNTAX_£RfiOR( "Basic  declaration" ) 
end  if; 

elSTf  (TM.MArCH(TM.TOKEN_PROCEDURE))  then 
if  (PROCEOURE_UNn)  then 
return  (TRUE); 
else 

P4.SYNTA)(_ERR0R("Basic  decl arat ion " )  • 

end  if; 

elsif  (TM.MATCH(TM,TOKEN_FUNCTION))  then 
if  (FUNCTrON_UNIT)  then 
return  (TRUE); 
else 

P4.SyNrAX_£RfiOR("8asic  declaration")- 
end  if; 

elsif  <TM.HATCH(TM.T0K£N_PACKAGE))  then 
if  (PACKAGE_0ECLARATI0N)  then 
return  (TRUE); 
else 

P4 . SYNTAX_£RROR( "Basic  dec  1 arat ion" ) ■ 
end  if; 

elsif  (TM.MATCH(TM.T0K£N_GENER1C))  then 
if  (GEN£R[C_0ECLARATI0N)  then 
return  (TRUE); 
el  se 

P4 . SyNTAx_ERROR( "Basic  dec  I arat  ion" )  • 
end  if, 

elsif  (P2. ID£NTIFIER_0ECLARATI0N)  then 
return  (TRUE); 

elsif  (TM,MATCH(TM,T0K£N_TASK))  then 
if  ( TASK_DECLARAT[0N)  then 
return  (TRUE); 
else 

P4.SyNTAX_ERROR( "Basic  declaration"); 
end  if; 
e  1  se 


if  procedure_unit  statement 


if  f unct ion_un i t  statement 


if  package_decl arati on 


if  generjc_dec)aration 


return  (FALSE); 
end  if; 

end  BASIC^DECLAHAHON; 


■  I  A  1 1 R  Of  CLARA  1 IVt  ITEM  -  > 

> 


PROPER  BODY 

generic  CLNtRIC  DtCl  ARAUON 


84 


--)  use  WITH_OR_USE_CLAUSE 
function  LATER  OF''laRATIVE_ITEM  return  boolean  is 
beg  in 

if  (PA.PRINTCALLS)  then 

P4.0UT_PUT("LATER_0ECLARATIVE_ITEM"); 
end  if; 

if  ( PROPERBOOY )  then  --  check  for  bodydeclaration 

return  (TRUE); 

elsif  (TM.MATCH(TM.TQKEN_GENERIC))  then 
if  (GENERIC_DECLARATION)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Later  declarative  item"); 
end  if;  --  if  genericdeclaration 

elsif  (TM.MATCH(TM.TOKEN_US£))  then 
if  (P2.UITH_0R_USE_CLAUSE)  then 
return  (TRUE); 
e  1  se 

P4 .SYNTAX_ERROR( "Later  declarative  item"); 
end  if;  --  if  «iith_or_use_clause 

else 

return  (FALSE); 
end  if; 

end  LATER_DECLARATIVE_ITEM; 


--  PR0PER_B0DY  procedure  PROCEDURE_UNr T 

-->  function  fUNCTION_UNIT 
-->  package  PACKAGE_DECLARATION 
-->  task  TASK_DECLARAIION 
function  PROPERBODY  return  boolean  is 
begin 

if  (P4,PRINT_CALLS)  then 
P4 .0UT_PUT( "PROPER_BODY" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_PROCEDURE))  then 
if  (PROCEDURE_UNIT)  then 
return  (TRUE); 
el  se 

P4.SYNTAX_ERR0R( "Proper  body"); 

end  if;  --  if  procedureun i t  statement 

elsif  (TM,MATCH(TM.TOKEN_FUNCTION))  then 
if  (FUNCTION  UNIT)  then 
return  (TRUE); 
else 

P4. SYNTAX  ERROR("Proper  body"); 

end  if;  --  if  f unct  lonun  1 1  statement 

elsif  (TM.MATCH(rM.TOKEN_PACKAGE))  then 
if  (PACKAGE  DECIARATIQN)  then 
l  elurn  ( [RUE  ) ; 
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e1  se 

P4.SYNTAX_ERR0R( "Proper  body"); 
end  if;  --  if 

elsif  (TM.MATCH(TM.TOKEN_TASK))  then 
if  (TASKOECLARATION)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Proper  body"); 
end  if; 
else 

return  (FALSE); 

end  if;  --  if 

end  PROPERBODY; 


--  SEOUENCE_OF_STATEMENTS  ->  [STATEMENT]+ 
function  SEQUENCEOFSTATEMENTS  return  boolean  is 
beg  1  n 

if  (P4.PRIMT_CALLS)  then 

P4.0UT_PUT("SE0UENCE_0F_STATEMENrS" ); 
end  if; 

if  (STATEMENT)  then 
while  (STATEMENT)  loop 
null  ; 
end  loop; 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  SEOUENCE_OF_STATEMENTS; 


--  STATEMENT  -->  [LABEL  ?]  SIMPLE_STATEMENT 

-->  [LABEL  ?]  COMPOUND_STATEMENT 
function  STATEMENT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "STATEMENT" ) ; 
end  if; 

if  (P2  lABEL)  then 
null; 
end  I  f ; 

if  (P2.SIMPLE_STATEMENT)  then 
return  (TRUE); 

elsif  (COMPOUND_STATEMENT)  then 
return  (TRUE); 
e  1  se 

return  ( F ALSE ) ; 


pacl(age_decl  arat  ion 


match ( tolcen_procedure ) 
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end  if; 

end  STATEMENT; 


--  COMPOUNDSTATEMENT  -->  if  IfSTATEHENT 

-->  case  CASE_STAT£M£NT 
-->  LOOP_STAT£MENI 
-->  BLOCK_STAT£M£NT 
-->  accept  ACCEPTSTATEMENT 
-->  SELECT_STAT£MENT 
function  COMPOUNO_STATEMENT  return  boolean  is 
STARTTOKEN  ;  TOKEN_SCANNER . TOKEN_ft£CORD_TYP£ ; 

LOCATIONONE  ;  positive; 

LOCATION_TWO  ;  positive; 
use  SYMBOL_TABLE : 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT( "COMPOUND_STATEMENr" ) ; 
end  if; 

if  (TM.MATCH(TM.TOAEN_IF))  then 
if  (If_STATEM£NT)  then 

COD£_BLOCK£R. INCR£M£NT_STATEM£NT_COUNT; 
return  (TRUE): 
else 

P4.SYNTAX_ERR0R( "Compound  statement" ) ; 
end  if;  --  if  if_statement 

elsif  (TM.MATCH(TM.TOKEN_CASE))  then 
if  (CASE_STArEM£NT)  then 
CODE _BL0CKER. INCREMENT _STArEMENT_COUNI; 
return  (TRUE); 
else 

P4 . SYNTAX_£RROR( "Compound  statement" ) ; 
end  if;  --  if  case_statement 

elsif  (LOOP_STATEMENT)  then 
return  (TRUE); 

elsif  (BLOCKSTATEMENT)  then 

C00E_BL0CKER. INCREMENr_STATEMENf_COUNT ; 
return  (TRUE); 

elsif(TM.MArCH(TM. rOKEN_ACCEPr) )  then 
if  (ACCEPTSTATEMENT)  then 
return  ( TRUE ) ; 
e  I  se 

P4 . SYNTAX_ERR0R( "Compound  statement" ) ; 
end  if;  -  if  acceptstalement 

elsif  (SELECr_STATEMENT)  then 
return  ( T RUE  ) ; 
e  1  se 

return  ( FAl St  )  ; 
end  If; 

und  COMPOUND  SIArtMlNl; 
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-  if  declarative_part  statement 
--  if  match( token_deci are) 


--  BLOCKSTATEMENT  -->  [declare  OECLARATIVEPART  ?] 

begin  SEQUENCE  Of  STATEMENTS  [exception 
[E3(CEPTIQN_HANDLER]r  ?]  ?]  end  [identifier  ?]  ; 
function  BLOCK_STATEMENT  return  boolean  is 
begin 

if  (P4.PR1NT_CALLS)  then 
P4 ,QUT_PUT("BLQCK_STATEM£MT" ) ; 
end  if; 

if  ( TM,MATCH(TM,T0KEN_DECLARE))  then 
if  (DECLARATIVE_PAfiT)  then 
null  ; 

else 

P4.SYNTAX_ERR0R( "Block  statement" ) ; 
end  if; 
end  if; 

if  (rM.MArCH(TM.TOKEN_BEGIN))  then 
if  (SEQUENCE_OF_STAT£MENTS)  then 
if  (TM  MATCH(TM,TOkEN_EXCEPTIOM))  then 
if  (£XCEPTI0N_HAN0L£R)  then 
•hile  (EXCEPTI0N_HAN0LER)  loop 
null; 
end  loop; 
else 

P4  SYNrAX_6RftOR( "Block  statement" ) ; 
end  If; 
end  if; 

If  (TM.MArCH(TM.rO(C£N_ENO))  then 
if  (TM.MATCH(rM,roxEN_IOENIIFIER))  then 
nul  1  ; 

--  if  match(  tokenident  1  f  ler ) 
if  (TM  MATCH( TM, TOKENSEMICOLON))  then 
return  (TRUE); 
e  1  se 

P4, SYNTAX _ERROR( "Block  statement"); 

»f  matcn{  tokensemico  Ion  ) 

e  1  se 

P^.SYNTAX  ERR0R("8lock  sta temen t" ) ; 

--  if  malch( tokenend ) 

e  I  se 

P4. SYNTAX  ERROR( "Block  statement"); 

-  if  sequence_of_statements 

e  1  se 

return  ( FALSE  )  ; 

-  if  match(token  begin) 

end  Bl  t)CK  STATEMENT; 


if  exc8ption_handler  statement 
if  niatch( token_except ion ) 
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--  If_STATtMENr  ■->  EXPRESSION  then  SEOUENCE_OF_STATEMENTS 

[etsif  EXPRESSION  then  SEOUENCE_OF_STATEMENTS]* 
[else  S£QUENCE_OF_STAT£MENTS  ?]  end  if  ; 
function  IF_STATEMENT  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 
P4 . 0UT_PUT( " I F_STA7EM£N  T ” ) ; 
end  if; 

if  (P3. EXPRESSION)  then 

if  (TM.MATCH(TM.TOI(EN_THEN))  ther 
if  (SEOUENCE_OF_SrATEM£NTS)  then 
while  (TM.MATCH(TM.TOKEN_ELSIf ))  loop 
if  (P3. EXPRESSION)  then 

if  ( TM.MATCH(TM. rOX£N_rH£M))  then 
if  not  (SEOUENCE_OF_SIAIEMENTS)  then 
P4.SYNTAX_ERR0R( "If  statement" ) ; 
end  if;  --  if  not  sequenceofstatements 

else 

P4.SYNTAX_ERROR("If  Statement"); 
end  if;  --  if  (iiatch( toXen_then ) 

e  1  se 

P4.SYNTAX_ERR0R("If  statement"); 
end  if;  --  if  expression  statement 

end  loop; 

if  (TM.MATCH(TM.TOXEN_ELSE))  then 
if  (SEOUENCE_Of .STATEMENTS)  then 
null; 
else 

P4.SYNTAX_ERR0R( "If  statement"); 
end  if;  --  if  sequence.of.statements 

end  if;  --  if  match( token.el se ) 

if  (TM.MATCH(TM,T0KEN_EN0))  then 
if  (TM.MATCH(TM.TOKEN_If ))  then 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4.SYNTAX.ERROR( "If  Statement"); 
end  If;  --  if  match( tokensemicol on  ) 

else 

P4.SYNTAX_ERROR("If  statement"); 
end  if;  --  if  match{ token.i f  ) 

e  1  se 

P4 .SYNTAX_ERROR( "If  statement" ) ; 
end  if;  --  if  match( tokenend ) 

else 

P4 . SYNTAX_ERROR( " If  statement"); 

end  if;  -if  sequenceof  statemen ts 

e  1  se 

P4. SYNTAX  tRR0R(”If  statement"); 
end  if;  --  if  match( token  then ) 

e  I  s  u 
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--  if  expression  statement 


return  (FALSE); 
end  if; 

end  IF^STATEMENF; 


--  CAS£_STATEMENT  -->  EXPRESSION  is  [CASE_STAT£MENT_ALTERNATIVE]+  end  case 
function  CASESf ATE M£NT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT( “CASE_STAT£M£NT" ) ; 
end  if; 

if  (P3. EXPRESSION)  then 

if  (TM.MATCH(TM.TOXEN_IS))  then 

if  (CASE_STATEMENT_ALTERNATIVE)  then 
while  (CASE_STATEM£NT_ALrERNATIV£)  loop 
null; 
end  loop; 

if  ( TM.MATCH( TM. TOKENENO) )  then 
if  (TM,MATCH(TM.TOKEN_CASE))  then 

if  (TM.MATCH(TM.TOK£N_S£MICOLON))  then 
return  (TRUE); 
e  1  se 

P4 .SYNTAX_ERROR( "Case  statement" ) ; 
end  if;  --  if  match( token_semicolon ) 

else 

P4 . SYNTAX_ERROR( "Case  statement" ) ; 
end  if;  --  if  match( token_case ) 

else 

P4 . SYNrAX_ERROR( "Case  statement" ) ; 
end  if;  --  if  match( toXen_end ) 

else 

P4 . SYNTAX  ERROR ( "Case  statement" ) ; 

end  if;  --  if  case_statement_al ternative 

else 

P4 . SYNTAX_ERROR( "Case  statement" ) ; 
end  if;  --  'f  match( tokenis ) 

e  1  se 

return  (FALSE); 

end  if;  ■■  if  expression  statement 

end  CAS£_STATEM£Nr; 


--  CASE^STATEMENTALTERNATIVE  -->  when  CHOICE  [|  CHOICE]*  => 

SEQUENCE_OF_STATEMENTS 

function  CASE  STATEMENIALTERNATIVE  return  boolean  is 
beg  in 

if  (P4. PRINT  CALLS)  then 

P4,OUT_PUT( "CASE  STAIEMENI  AL  TERNAIIVE” ) ; 
end  if; 
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if  (TM.MATCH(TM.TOKEN_WHEN))  then 
if  (P3. CHOICE)  then 

while  (TM.MATCH(TM.rOKEN_BAR))  loop 
if  not  (P3. CHOICE)  then 

P4.SYNTAX_ERR0R(”Case  statement  alternative”); 
end  if;  --  if  not  choice  statement 

end  loop; 

if  (TM.MATCH(TM.TOKEN_ARROW))  then 
if  (SEQUENCE  OFSTATEMENTS)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROfi( “Case  statement  alternative”); 
end  if;  --  if  sequence_of_statements 

else 

P4 . SYNTAX_ERROR( "Case  statement  alternative”); 
end  if;  --  if  match( token_arrow) 

else 

P4 . SYNTAX_ERROR( “Case  statement  alternative"); 
end  if;  --  if  choice  statement 

else 

return  (FALSE); 

end  if;  --  if  match( tokenwhen ) 

end  CASE  STATEMENTALTERNATIVE ; 


--  LOOP_STATEMENT  -->  [ITERATION_SCHEM£  ?]  loop 

SEQUENCE_OF_STATEMENTS  end  loop  [identifier  ?]  ; 
function  LOOP_STATEMENT  return  boolean  is 
STOP_TOKEN  ;  TOkEN.SCANNER . T0KEN_REC0R0_TYPE ; 

LOCATION_ONE  :  natural; 

LOCATION_TWO  ;  positive; 
use  SYMB0L_TA8LE; 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT( "LOOP_STATEMENT" ) ; 
end  if; 

if  (P3.ITERATION_SCHEME)  then 
null  ; 

end  if;  --  if  iteration_scheme  statement 

if  (TM.MATCH(TM.TOKEN_LOOP))  then 
T»4.MATCHED_TOKEN(STOP_TOKEN); 

if  (COOE_flLOCXER.CURRENT_STATEHENT_COUNT  /=  0)  then 

LOCATIONONE  ;=  C0D£_BL0CKER . CURRENr_COOE_BLOCK_NUMBER ; 

COOE_BLOCKER . EXI T_CODE_BLOCX( ST0P_T0KEN . SOURCE ) ; 
COOE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE,  “LOOP  BLOCK"); 
LOCATION  TWO  ;=  C0D£_8L0CKER. CURRENT  CODE  BLOCK_NUMBER; 

COOE_BLOCKER . INCREM£NT_STATEMENT_COUNT ; 
NET_GENEHAT0R.C0NNECT_8L0CKS(L0CAI10N_0NE,  LOCATIONTWO) ; 

SYMBOL  TABLE. INSERT _SYMTAB( "LOOP",  LOOP  TAG,  LOCATIONTWO ) ; 

SYMBOl  TABLE. INStRT_SYMrAB(”ENO",  LA8EL_NAME,  0); 
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el  se 

CODE_BLOCKER.DELETE_COOE_BLOCK_ENTER; 

COOE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE.  "LOOP  BLOCK"); 
COOEBLOCKER.INCREMENTSTATEMENTCOUNT; 

LOCATION_TWO  CODE_BLOCKER.CURRENT_COOE_BLOCK_NUMBER; 
SYMBOL_TABLE.INSERT_SYM_TAB("LOOP“.  LOOP_TAG.  LOCATION_TWO) ; 
SYMBOL_TABLE.INSERT_SYM_TAB("END".  LAeEL_NAME .  0); 
end  if; 

if  (SEOUENCE_OF_STATEMENTS)  then 

if  (COOE_BLOCKER.CURRENT_STATEMEMT_COUNT  =  0)  then 
LOCATION_ONE  :=  0; 

COOE_BLOCKER. DELETE  CODEBLOCKENTER; 
else 

TM.MATCHEO_TOKEN(STOP_rOKEN); 

LOCATION_ONE  :=  CODE_BLOCKER.CURR£MT_CODE_BLOCK_NUMBER; 

CODE_BLOCKE  R . EX  I T_COOE_BLOCK ( STOP  TOKEN . SOURCE ) ; 
end  if; 

if  (TM.MATCH(TM. TOKEN  END))  then 
if  (TM.MATCH(TM.TOKEN_LOOP))  then 
TM.MATCH£0_T0KEN(ST0P_T0KEN); 

CODE_BLOCKER.ENTER_COOE_BLOCK(STOP_TOK£N. SOURCE,  "END  LOOP"); 
COD£_BLOCKER . INCREM£NT_STAT£MENT_COUNT ; 

LOCATION_TWO  :=  CODE_BLOCKER .CURRENT_CODE_BLOCK_NUMBER ; 
if  (SYMBOL_T ABLE. flNO_LOCAL_KEy( "END")  =  null)  then 
raise  SYMBOL_TABLE .REEER£NCE_ERROR; 
else 

SYMBOL_TABLE.UPDAT£_SYM_TAB(LOCATION_TWO); 
end  if; 

if  (LOCATION_ON£  =  0)  then 
NET_GENERATOR.£XPLICIT_ENO(LOCATION_T«0); 
else 

NET_G£NERATOR.CONNECr_BLOCKS(LOCATION_ONE,  LOCATION_TWO) ; 
end  if; 

C0DE_8L0CKER . EX  I T_C0DE_8L0CK( STOP_TOKEN . SOURCE ) ; 

COOE_BLOCKER . ENTER_CODE_BLOCK( STOP_TOKEN . SOURCE ,  " " ) ; 
if  (TM.MATCH(TM. rOKEN_[DENTIFIER))  then 
null; 

end  if;  --  if  match( token_identif ier) 

if  (TM.MATCH(TM.TOKEN_SEM[COLON))  then 
SY«90L_TABLE . EXI TSCOPE ; 

N£T_GENERATOR.END_LOOP(LOCATION_TWO.  SYMBOL  TABLE . RETRIEVE  SYM) ; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Loop  statement:  expecting  semicolon"); 
end  if;  --  if  malch( loKen  semicolon ) 

else 

P4 . SYNTAX_ERROR( "Loop  statement;  end  must  be  fully  bracketed"); 
end  if;  --  if  match( tokenloop) 

e  1  se 

P4 . SYNTAX  ERROR( "Loop  statement:  expecting  'end'"); 
end  if;  --  if  match( token_end) 
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else 

P4 . SYNTAX_ERROR( “Loop  statement: 
end  if; 
else 

return  (FALSE); 
end  if; 

end  LOOPSTATEMENT; 


expecting  sequence  of  statements"), 
--  if  sequence_of_statements 

--  if  match( tokenloop) 


--  EXCEPTION_HANOLER  -->  when  EXCEPTION_CHOICE  [j  EXCEPT10N_CH0ICE]»  => 

SE0UENCE_OF_STATEMENTS 

function  EXCEPTIONHANOLER  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUr( "EXCEPTIONHANOLER" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_WHEN))  then 
if  (P2.£XCEPTI0N_CH0ICE)  then 
while  (TM.MATCH(TM.TOKEN_BAR))  loop 
if  not  (P2.EXCEPTI0N_CH0ICE)  then 

P4 . SYNTAX_ERROR( "Exception  handler" ) ; 
end  if;  --  if  not  exception_choice 

end  loop; 

if  (TM.MArCH(TM.rOK£N_ARRO«))  then 
if  (SEQUENCE_OF_STATEM£NTS)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Exception  handler"); 
end  if;  --  if  sequence_of_statements 

e  I  se 

P4 . SYNTAX_ERROR( "Exception  handler"); 
end  if;  --  if  roatch( token_arrow ) 

else 

P4 . SYNTAX_ERROR( "Exception  handler"); 
end  if;  --  if  exceptionchoice  statement 

e  I  se 

return  (FALSE); 

end  if;  --  if  match( token-when ) 

end  EXC£PIION_HANOL£R; 


-  ACCEPTSTATEMENT  -->  identifier  [(EXPRESSION)  ?]  [FORMAL_PART  ?] 

[do  SEQUENCE_Of_STATEMENTS  end  [identifier  ?]  ?]  ; 
function  ACCEPTSTATEMENT  return  boolean  is 
ST0P_T0KEN  :  TOKEN  SCANNER. TOKENHECORO  TYPE; 

LOCATION  ONE  :  natural; 

LOCATIONTWO  :  positive; 
use  SYMBOL  TABLE; 
beg  1  n 
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if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT( "ACCEPT  STATEMENT"  ); 
end  i  f  ; 

if  ( TM.MATCH(TM.TOKEN_IDENTIf lER))  then 
TM . MATCHEO_TOKEN( STOP_TOKEN ) ; 

if  (COOEBLOCKER.CURRENTSTATEMENTCOUMT  /=  0)  then 
CODE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

LOCATIONONE  :=  CODE_BLOCKER .CURRENT_COOE_BLOCK_NUMBER ; 
else 

C0DE_BL0CKER.DELETE_C0DE_BL0CK_ENTER; 

CODE_BLOCKER.ENTER_CODE_BLOCK(S1  TOKEN . SOURCE ,  "ACCEPT  STATEMENT") 
COOE_BLOCKER.INCREMENT_STATEM£NT_CCJNT; 

LOCATION_ONE  :=  COOE_BLOCKER . CURREMT_COOE_BLOCK_NUMBER ; 
end  if; 

CODE_BLOCKER.ENTER_COOE_8LOCK(STOP_TOKEN. SOURCE,  "ENTRY  BLOCK"); 
LOCATION_TWO  :=  COOE_BLOCKER .CURRENT_COOE_BLOCK_NUMBER ; 

CODE_BLOCKER . INCREM£NT_STATEM£NT_COUNT ; 

NE  T  GENERATOR . TASK_ACCEPT( LQCATION_ONE ,  LOCATION_TWO ) ; 

SYMBOLTABLE . INSERT_SYM_TAB( STOP_TOKEN . LEXEM£( 1 . . STOP  TOKEN . 

LEXEME_SI2E).  SYMBOL_TABLE . ACCEPTTAG , 
LOCATION_TUO); 

COOE_BLOCKER . EXT  T_CODE_BLOCK( STOP_TOK£N . SOURCE ) ; 
if  (TM.MATCH(TM.TOKEN_L£rT_PAfiEN))  then 
if  (P3. EXPRESSION)  then 

if  (TM.MATCH(TM.TOK£N_RIGHT_PAREN))  then 
null; 
else 

P4 . SYNTAX_ERROR( "Accept  statement" ) ; 
end  if;  --  if  match( token_ri9ht_paren ) 

else 

P4 . SYNTAX_ERROR( “Accept  statement" ) ; 
end  if;  --  if  eipression  statement 

end  if;  --  if  match( toKen_lef t_paren ) 

if  (P2 .FORMAL_PART)  then 
null; 

end  if;  --  if  formal_part  statement 

if  (TM.MATCH(TM.T0KEN_00))  then 
TM.MATCHE0_T0KEN(ST0P_T0KEN); 

CODE  BLOCKER . EX  I T_C0DE_BL0CK( STOP  TOKEN . SOURCE ) ; 

COOE_BLOCKER . £NTER_CODE_BLOCK( STOP_TOKEN . SOURCE , 

"BEGIN  ACCEPT  STATEMENTS"): 

CODE  BLOCKER . INCREMENTSTATEMENTCOUNT ; 
if  (SEQUENCE_OF_STATEMENTS)  then 

if  (CODE_BLOCKER.CURRENT_STATEMENT_COUNT  =  0)  then 
LOCATION  ONE  ;=  0; 

COOE_8LOCKER.DELETE_COOE_BLOCK_£NTER; 
e  1  se 

TM.MATCHED_TOKEN(STOP_IOKEN) ; 

LOCATIONONE  :=  C00t_BL0CKER .CURRENTCODEBLOCKNUMBER ; 

CODE  BLOCKER.EXI T  CODE  BlOCK(STOP_rOKEN.SOURCE); 
ei'd  1  f  ; 
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if  (TM.MATCH(TM.TOKEN_ENO))  then 
TM.MATCHED_TOKEN(STOP_TOKEN); 

CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_TOKEN. SOURCE,  "END  ENTRY  BLOCK"); 
CODE_BLOCKER. INCREMENTSTATEMENTCOUNT; 

LOCATION_TWO  :=  COOE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 
if  (SYMBOL_TABLE.FINO_LOCAL_KEY("ENO")  =  null)  then 
raise  SYMBOL_TABLE . REFERENCE_ERROR: 
el  se 

SYMBOL_TABLE . UPOATE_SYM_TAB( LOCATION_TWO ) ; 
end  if; 

if  (LOCATION_ONE  -  0)  then 
NET_GENERATOR.EXPLICIT_ENO_ACC£PT(LOCATION_TWO); 
else 

NETGENERATOR . ENO_ACCEPT( LOCATION _ONE .  LOCATION_TUO) ; 
end  if; 

COOE_BLOCKER.EXIT_COOE_BLOCK(STOP_TOKEN.SOURCE); 

CODEBLOCKER . ENTER_CODE_aLOCK( STOP_TOKEN . SOURCE ,  " " ) ; 
if  (TM.MATCH(TM.TOKENJOENTIFIER))  then 
nul  I  ; 

end  if;  --  if  match( token_ident i f ier ) 

else 

P4 . SYNTAX_ERROR( "Accept  statement" ) ; 
end  if;  --  if  match( token_end ) 

else 

P4.SYNTAX_ERR0R( "Accept  statement"); 
end  if;  --  if  sequence_of_statements 

end  if;  --  if  match(toKBn_do) 

if  (TM.MATCH(TM.T0KEN_SEMIC0L0N))  then 
SYMBOL_TABLE.EXIT_SCOP£; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Accept  statement" ) ; 
end  if;  --  if  match( token_semicolon ) 

else 

return  (FALSE); 

end  if;  --  if  match( toKenidentif ier) 

end  ACCEPT_STATEMENT; 


--  SELECTSTATEMENT  -->  select  SELECT  STATEMENTTAIL  [  SELECTENTRYCALL  ?j 

end  select  ; 

function  SELECTSTATEMENT  return  boolean  is 
STOP_TOKEN  :  TOKEN_SCANN£R. TOKEN  R£CORD_TYPE, 

LOCATIONONE  :  positive; 

LOCATIONTWO  :  positive; 
use  SYMBOL_TABLE ; 
beg  1  n 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("SELECT_STATEMENT"); 
e  fi  d  if; 


f  (TM.MATCH(TM.TOKEN_SELECT))  then 
TM.MATCHEO_TOKEN(STOP_TOKEN); 

if  (CODE_BLOCKER.CURRENT_STATEMENT_COUNT  /=  Q)  then 

LOCATIONONE  COOE_BLOCKER . CURR£NT_COOE_BLOCK_NUMBER ; 

COOE^BLOCKER . EXI T_COOE_BLOCK( STOPTOKEM . SOURCE ) ; 
CODE_BLOCKER.ENTER_CODE_BLOCX(SrOP_TOKEM. SOURCE.  "SELECT  BLOCK") ; 
COO£_BLOCKER.INCREMENT_STATEHENT_COUMT: 

LOCATIONTWO  :=  COOE_BLOCKER.CURR£NT_COOE_BLOCK_NUMBER; 
NET_GENERATOR.CONMECT_BLOCKS(LOCATION_OM£.  LOCATION_TWO) ; 
e  1  se 

CODE_BLOCKER.OELETE_COOE_BLOCK_ENTER; 

CODE_BLOCKER.ENTER_COO£_BLOCK(STOP_TOKEN. SOURCE,  "SELECT  BLOCK"); 
COD£_BLOCKER.INCREMENT_STATEMENT_COOMT; 

LOCATIONTWO  ;=  CODE_BLOCKER . CURR£NT_C00E_8L0CK_NUMB£R ; 
end  if; 

SYMBOL_TABLE . I NSERT_SYM_TAB( "SELECT" .  SELECTTAG,  LOCATIONTWO) ; 
SYMBOL_TABL£.INS£RT_SYM_TAB("END”,  LABEL_NAN£.  0); 

NET_GENERATOR.OECISION_START( LOCATION_TWO,  SYMBOL_TABLE . RE TRI EVE_SYM ) ; 
if  (SELECTSTATEMENTTAIL)  then 
if  (SELECT_ENTRY_CALL)  then 

if  ( TM.MATCH( TM. TOKEN  ENO) )  then 
if  (TM,MATCH{TM.TOKEN_SELECT))  then 
if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
TM.MATCHED_TOK£N(STOP_TOK£N); 

if  (C00E_BL0CKER.CURR£NT_STAT£MENT_C0UNT  /=  0)  then 
LOCATION_ONE  :=  COOE_BLOCKER .CURRENT_COOE_BLOCK_NUMBER ; 
COOE_BLOCKER . EX  I T_COO£_BLOCK( STOP_TOKEN . SOURCE  ) ; 
NET_G£NERATOfi , £N0_0£CISI0N( LOCATION_ONE ) ; 
e1  se 

COOE_BLOCKER,0£LETE_COOE_8LOCK_ENTER; 
N£T_GENERAI0R.EXPLICIT_END_0£CIS10N; 
end  if; 

C00E_8L0CKER.ENTER_C00E_BL0CK(ST0P_T0KEN, SOURCE.  "END  SELECT") 
C0DE_BL0CKER . INCREMENT_STATEMENT_COUNT ; 

LOCAriON_ONE  :=  C00E_BL0CKER . CURRENT_CODE_BLOCK_NUMBER ; 
if  (SYMBOL_TABLE.FIND_LOCAL_KEY('ENO”)  =  null)  then 
raise  SYMBOL_TABLE . RE FERENCE_ERROR ; 
e  1  se 

SYMBOL  TABLE . UPDATE_SYM_TAB( LOCATION  ONE  ) ; 
end  if; 

COOE_8LOCKER.EXIT_COOE_BLOCK(STOP_TOK£N.SOURCE); 
CODE_BLOCKER.ENTER_CODE_BLOCK(STOP_rOKEN. SOURCE ,  "" ) ; 
SYMBOLTABLE .EXIT  SCOPE ; 
return  (TRUE); 
else 

P4.SYNTAX_ERROR(" Select  statement" ) ; 
end  if;  --  if  match( toKensemi col  on ) 

e  1  se 

P4 . SYNT AX  ERROR ( "Select  statement" ) ; 
end  if; 


if  ma tch ( token  se I ec t ) 


P4 . SYNTAX_ERROR( "Select  statement" ) ; 
end  if;  --  if  match( toXenend ) 

elsif  (TM.MATCH(TM.TOKEN_ENO))  then 
if  (rM.MATCH(TM.TOKEN_SELECT))  then 
if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
TM.MATCHED_TOKEN(STOP_TOKEN): 

if  (C00E_8L0CKER.CURRENT_STArEMENT_C0UNr  /=  0)  then 

LOCATIONONE  :=  COOE_BLOCKER .CURRENT_CODE_BLOCK_NUM8ER ; 
COOE_8LQCKER  .  EXIT_COOE_BLOCtt(  STOP_TOK£« .  SOURCE ) ; 
NET_GENERATOR.END_OECISION{LOCATION_ON£): 
else 

COOE_BLOCKER.DELETE_CQQE_BLOCK_£NT£R; 
NET_GEN£RATOR.EXPLICrT_END_0£CISION; 
end  if : 

COD£_BLOCKEH.ENTER_COO£_8LOCK(STOP_TOK£N. SOURCE,  "END  SELECT"); 
C00£_BL0CKER . INCREMENT_STAT£MENT_COUNT ; 

LOCATION_ONE  COOEBLOCXER . CURR£NT_COOE_BLOCX_NUMBER ; 
if  (SYMB0L_TA8LE.FIND_L0CAL_K£Y(”EN0')  =  null)  then 
raise  SYM80L_TABLE . REFER£NCE_ERROR; 
else 

SYM60L_TA8L£ . UPDATE_SYM_TAB( LOCATIONONE ) ; 
end  if; 

COOE_BLOCXER . EX  I T_COO£_BLOCX( STOP_TOK£N . SOURCE ) ; 

CODE_BLOCKER . ENTER_COOE_8LOCX(STOP_TOX£N . SOURCE ,  " " ) ; 

SYMBOL_T ABL  £ . £  X I T_SCOPE ; 
return  (TRUE); 
else 

P4 . SYNTAX_£RROR( "Select  statement" ) ; 
end  if;  --  if  match( token_semicolon ) 

else 

P4  .SYN1AX_ERR0R( "Select  statement" ) ; 
end  if;  --  if  match( token_select) 

e  1  se 

P4 . SYNTAX_ERROR( "Select  statement" ) ; 
end  if;  --  if  raatch( token_end ) 

else 

P4 . SYNTAX_ERROR( "Select  statement" ) ; 
end  if;  --  if  select_statement_tai 1 

e  1  se 

return  (FALSE); 
end  if; 

end  SEl EC1_STATEMENT ; 


--  SELECTSTATEMENITAIL  -->  SELECTAL TERNATIVE  [or  SE LEC TALTERNAT I VE ]• 

-  >  NAME  ;  [SEOUENCE_OF_STATEMENTS  ?] 
function  SELECT_STATEMENT_TAIL  return  boolean  is 
ST0P_T0KEN  ;  I0KEN_SCANNER.T0XEN  RECORD  TYPE; 
location  ONE  :  positive; 

SFAKCH  POINIFR  :  SYMBOl  I  ABl  t  ,  SYM  TABACCE  SS ; 


97 


use  SYMBOL_TABLE; 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "SELECTSTATEMENTTAIL" ) ; 
end  if; 

if  (SELECT_ALTERNATIVE)  then 
while  (TM.MATCH(TM.TOKEN_OR))  loop 
TM.MATCHEO_TOKEN(STOP_TOKEN); 

if  (C00E_8L0CKER.CURR£NT_STATEMENT_C0UNT  /=  0)  then 

LOCATIONONE  :=  COOE_BLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

COOE_BLOCKER . E  X I T_C00E_BL0CK( STOP_TOKEN . SOURCE ) ; 
MET_GEMERATOH.DECISIOM_OR(LOCATIOI*_ONE); 
else 

CODE_BLOCKER.DELETE_COOE_BLOCK_ENTER; 
NET_GENERATOR.EXPLICIT_OECISION_OR; 
end  if; 

if  not  (SELECTALTERNATIVE )  then 

P4 . SYNTAX_ERROR( "Sel ect  statement  tail”); 
end  if; 
end  loop; 
return  (TRUE); 
else 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 

if  (P3.NAME)  then  --  check  for  entry  call  statement 

TM . MATCHED_TOKEN( ST0P_T0KEN ) ; 

SEARCH_POINTER  ;=  SYMBOL_TABLE . RETRIEVE_SYM; 
if  ((S£ARCH_P0INTER  /=  null)  and  then 
(SEARCH_POINTER.TAG_TYPE  =  SYMBOL_TABLE . ENTRY_TAG) )  then 
LOCATION_ON£  :=  C00E_8L0CKER . CURR£NT_CODE_BLOCK_NUMBER ; 
CODE_BLOCkER.INCREMENT_STAT£MENT_COUNT; 

C00E_BL0CKER . EX  I T_COOE_BLOCK( STOP_TOK£N . SOURCE ) ; 

NET_GENERATOR . ENTRY_CALL( LOCAriON_ONE ,  SEARCH_POINTER) ; 
CODE_BLOCKER.ENTER_COOE_BLOCK(STOP_TOKEN. SOURCE,  "") ; 

SYMBOLTABLE . RESTORE_CURRENT_ENTRY ; 
else 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
return  (FALSE); 
end  if; 

if  (TM.MATCH(TM. TOKEN  SEMICOLON))  then 
if  (S£0UENCE_OF_STATtMENTS)  then 
null; 

end  if;  --  if  sequence_of_statements 

return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Se I ect  statement  tail"); 
end  if;  --  if  match( tokensemicol on ) 

e  1  se 

return  (FALSE); 
end  if; 

end  if;  --  if  select  alternative  statement 

end  SEI  ECr  SIAIEMENT  TAIL ; 
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SELECTALTERNATIVE  [when  EXPRESSION  ->  ?]  accept  ACCEPTSTATEMENT 

[SEOUENCE_OF_STAT£MENTS  ?] 

[when  EXPRESSION  =>  ?]  delay  DELAYSTATEMENT 
[SEQUENC£_Of_STATEMENTS  ?] 

"X  [when  EXPRESSION  =>  ?]  terminate  : 
function  SELECT_ALTERNATI\/E  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT(  •'SELECT_ALTERNATIVE"  ); 
end  if; 

if  (TM.MATCH(TM.T0KEN_WHEN))  then 
if  (P3. EXPRESSION)  then 
if  (TM.MATCH(TM.T0KEN_ARR0W))  then 
null  ; 
else 


P4.SYNTAX_£RR0R("Select  alternative"); 
end  if; 
else 


if  match( tokenarrow) 


P4 .SYNTAX_£RRQR( "Select  alternative"); 
end  if; 

end  if; 

if  (TM.I4ATCH(TM.T0KEN_ACC£PT))  then 
if  (ACCEPT_STATEM£NT)  then 
If  (SE0UENC£_Of_STATEM£NTS)  then 
null; 
end  if; 

return  (TRUE): 
el  se 

P4 . SYNTAX_ERROR( "Select  alternative"); 
end  if; 

elsif  (TM.MATCH(TM.T0KEN_DELAY))  then 
if  (P3.0ELAY_STATEMENT)  then 

if  (SEOUENCE_OF_STATEMENTS)  then 
null; 
end  if; 

return  (TRUE); 
else 

P4. SYNTAX _ERR0R(" Select  alternative"); 
end  if; 

elsif  (TM.MATCH(TM. TOKEN  TERMINATE))  then 
If  ( rM.MATCH( TM. TOKENSEMICOLON) )  then 
return  (TRUE); 
e  I  se 


if  expression  statement 
if  match( token_when) 


if  sequence_of_statements 


if  accept_statement 


If  sequence_of_statements 


if  delay_statement 


P4.SYNrAX  ERR0R(" Select  dl'.ernative"); 
end  if; 
e  1  se 


if  match( token  sem i CO  1  on ) 


return  (  iAtSE  )  ; 
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--  if  match( token  accept ) 


end  i  f  ; 

end  SELECT_ALTERNATIVE ; 


--  SELECTENTRYCALL  -->  else  SE0UENCE_Of_STATEMENTS 

-->  or  delay  OELAYSTATEMENT  [SEQUENCEOFSTATEMENTS  ?] 
function  SELECTENTRYCALL  return  boolean  is 
STOPTOKEN  :  TOKENSCANNER . TOKEN_RECOfiD_TYPE ; 

LOCATIONONE  :  positive, 
begin 

if  (P4.PRINT_CALLS)  then 

PA .0UT_PUT( "SELECT_ENTRY_CALL" ) ; 
end  if; 

if  (TM.MATCH(TM.T0K£N_ELSE))  then 
TM.MATCHED_TOKEN(STOP_TOKEN); 

if  (CODE_BLOCKER.CURRENT_SrATEMENT_COUNT  /=  0)  then 

LOCATIONONE  :=  CODEBLOCKER . CURRENT_CODE_BLOCK_NUMBER ; 

CODE_BLOCKER . EX  I T  CODE_BLOCK( SrOP_TOKEN . SOURCE ) : 
NET_GENERArOR.OECISION_OR(LOCATION_ONE); 
el  se 

COOE_BLOCKER.OELErE_CODE_BLOCK_ENTER; 

NET_6ENERAT0R.£XPLICIT_DECISI0N_0R; 
end  if; 

if  (SE0UENCE_0F_STAT£MENTS)  then 
return  (TRUE); 
else 

P4. SYNTAX JRROR("Select  entry  call"); 
end  if;  --  if  sequence_of_statements 

elsif  (TM.MATCH(TM.TOKEN_OR))  then 
if  (TM.MATCH{ TM. rOKEN_DELAY) )  then 
if  (P3.D£LAY_STATEM£NT)  then 

if  (SE0UENCE_Of_STATEMENTS)  then 
null; 

end  if;  --  if  sequence_of_statenients 

return  ( TRUE  ) ; 
else 

P4 . SYNTAX_ERROR( "Sel ect  entry  call"); 
end  if;  --  if  delay_statement 

else 

P4 . SYNTAX_tRROR( "Sel ec t  entry  call"); 
end  if;  --  if  iiiatch(  tokendel  ay  ) 

e  1  se 

return  (FALSE); 

end  if;  --  if  niatch(  token_e  1  se ) 

end  SELECTENTKY  CALL ; 

end  PARSER  1; 
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n  FLE  : 


AOAFlOW 


--  MODULE  NAME:  PACKAGE  PARSERS 

--  file  name  :  PARSER2.ADS 

-  DATE  CREATED:  20  FEB  88 

--  LAST  MODIFIED;  28  APR  88 

--  AUTHOR(S):  LT  ALBERT  J.  GRECCO,  USN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY; 

LCOR  JEFFREY  L.  NIEDER,  USN 
LT  KARL  S.  FAIRBANKS.  JR..  USN 
LCOR  PAUL  M.  HER2IG.  USN 

DESCRIPTION;  This  package  defines  the  functions 

that  are  the  middle  level  productions  for  a  top-down 
recursive  descent  parser. 


package  PARS£R_2  is 

function  GENERIC_ACTUAL_PART  return  boolean; 
function  G£NERIC_ASSOCI ATION  return  boolean; 
function  GEN£RIC_FORMAL_PARAME TER  return  boolean; 
function  CEN£RIC_TYP£_0EF1NITI0N  return  boolean; 
function  PRIVAT£_TYP£_DECLARAT ION  return  boolean; 
function  TYPE_DECLARATION  return  boolean; 
function  SU8TYP£_DECLARATI0N  return  boolean; 
function  OISCRIMINANT_PART  return  boolean; 
function  OISCRIM1NANT_SPECIFICATION  return  boolean; 
function  TYPEOEF INI T ION  return  boolean; 
function  RECORO_TYPE_DEFINI T ION  return  boolean; 
function  COMPONENTLIST  return  boolean; 
function  COMPONENFDECLARATION  return  boolean; 
function  VARIANTPART  return  boolean; 
function  VARIANT  return  boolean; 
function  Wl TH_OR_US£_CLAUSE  return  boolean; 
function  FORMALPART  return  boolean; 
function  IDENTIFIERDECLARATION  return  boolean; 
function  IDENTI FIERDECLARATIONTAIL  return  boolean; 
function  E)(CEPTI0N_TA1L  return  boolean; 
function  EXCEPTIONCHOICE  return  boolean; 
function  CONSTANTTERM  return  boolean; 
function  lOENT I F I ERTAI L  return  boolean; 
function  PARAMETERSPECl F ICATION  return  boolean; 
function  I  DENT  I F I  ERL  I  ST  return  boolean; 
function  MODE  return  boolean; 
function  UESIGNAIOH  return  boolean; 
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function 
function 
function 
function 
funct ion 
function 
end  PARSER 


SIMPLESTATEMENT  return  boolean; 
ASSIGNMENT_OR_PROCEDLIRE_CALL  return  boolean: 
LABEL  return  boolean; 

ENTRYDECLARATION  return  boolean; 
REPRESENTATIONCLAUSE  return  boolean; 
RECOROREPRESENTATIONCLAUSE  return  boolean; 
2; 
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TITLE- 


AOAFLOW 


MODULE  NAME: 
FILE  NAME: 

DATE  CREATED: 
LAST  MODIFIED: 


PACKAGE  PARSER_2 
PARSER2.AD8 

20  FEB  88 
28  APR  88 


--  AUTHOR{S):  LT  ALBERT  J.  GRECCO.  USN 


--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY; 

LCDR  JEFFREY  L.  NIEDER.  USN 
LT  KARL  S.  FAIRBANKS.  JR..  USN 
LCDR  PAUL  M.  HERZIG.  USN 


DESCRIPTION:  This  package  implements  the  functions 

that  are  the  middle  level  productions  for  a  top-down, 
recursive  descent  parser.  Each  function  is  preceded 
by  the  grammar  productions  they  are  implementing. 


with  PARS£R_3,  PARSER_4.  TOKENMATCHER.  TOKEN_SCANNER. 

COOE_BLOCKER,  SYMBOL_TABLE ,  NET_GEMERATOR; 

package  body  PARSER_2  is 

package  TM  renames  TOKENMATCHER; 
package  P3  renames  PARSER_3; 
package  P4  renames  PARS£R_4; 

--  GENERIC_ACTUAL_PART  -->  (GENERIC_ASS0C1ATI0N  [,  GENERIC_ASSOCIATION]*  ) 
function  GENERIC_ACTUAL_PART  return  boolean  is 
begin 

if  (PA.PRINTCALLS)  then 

P4.0UT_PUT("GENERIC_ACTUAL_PART"); 
end  if; 

if  ( TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
if  (GENERIC_ASSOCIATION)  then 
while  (TM.MATCH(TM.TOKEN_COMMA))  loop 
if  not  (GENERIC_ASS0C1AT10N)  then 

P4 . SYNTAX_ERROR( "Generic  actual  part"); 
end  if;  --  if  not  genericassociation 

end  loop; 

If  ( TM.MATCH( TM. TOKEN  RIGHIPAREN) )  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Generic  actual  part"); 
end  if;  --  if  match(token  rightparen) 

e  I  se 
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If  generic  association  statement 


P4 . SYNTAX_ERROR( "Generic  actual  part"); 
end  if; 
else 

return( FALSE ) : 

end  if;  --  if  match( token_lef t_paren ) 

end  GENERIC_ACTUAL_PART; 


--  GENERIC_ASSOCIATION  -->  [GENERIC_FORIitAL_PARAMETER  ?]  EXPRESSION 
function  GENERIC_ASSOCIATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "GENER1C_ASS0CIATI0N" ) ; 
end  if; 

if  (GENERIC_FORMAL_PARAMETER)  then 
null; 

end  if;  --  if  generic_formal_parameter 

if  ( P3 . EXPRESSION )  then  --  check  generic_actual_parameter 

return  (TRUE); 
else 

return  (FALSE); 

and  if;  --  if  expression 

end  GENERIC_ASSOCIATION; 


--  GENER1C_F0RMAL_PARAMETER  -->  identifier  => 

-->  string_l i tera 1  => 

function  GENERIC_FORMAL_PARAMETER  return  boolean  is 
PEEK_AHEAD_TOKEN  :  TOKEN_SCANNER . TOKEN_RECORO_TYPE ; 

TEST_TOkEN  ;  TOKEN.SCANNER . TOKEN_RECORO_TYPE ; 

use  TOkEN_SCANNER; 

begin 

if  (P4.PRINT_CALLS)  then 

P4 , 0UT_PUT( "GENERIC_fORMAL_PARAMETER’ ) ; 
end  if; 

TESTTOKEN. LEXEME  ;=  (others  =>  '  '); 

TEST_TOKEN,LEXEME( 1. .2)  := 

TEST_TOKEN.LEXEME_SIZE  2; 

TEST  TOKEN. TOKEN_TYPE  TOKENSCANNER .DELIMI TER ; 
TM.NEXT_TOKEN(PEEK_AHEAD_TOKEN) ; 
if  (PEEK_AHEAD_TOKEN  =  TESTTOKEN)  then 
if  (TM.MATCH(TM.TOKEN_IDENTIFIER))  then 
if  (TM.MATCH(TM.TOKEN_ARROW))  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Generic  formal  parameter"); 
end  if;  --  if  match( tokenarrow) 

elsif  (TM.MATCH(TM.TOKEN_STRING_LITERAL))  then 
if  ( rM.MATCH( TM. TOKENARROW))  then 
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return  (TRUE); 
else 

P4 . SYNTAX_£RROR( "Generic  formal  parameter”); 
end  if;  --  if  match(  token_arro\<() 

el  se 

P4 . SYNTAX_ERROR( “Gener 1 c  formal  parameter"); 
end  if;  --  if  match( token_identif ier ) 

else 

return  (FALSE); 

end  if;  --  if  1ookahead_token  =  "=>" 

end  GENERIC_FORMAL_PARAMETER; 


--  GENERIC_TYPE_DEFINITION  --> 

--> 

--> 

--> 

--> 

--> 

function  GENERIC  TYPE  DEFINITION 


(  <>  ) 
range  <> 
digits  <> 
delta  <> 

array  ARRAY_TYP£_0EF1NITI0N 
access  SUBTYPE_INDICATION 
return  boolean  is 


begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT(*G£NERIC_TYPE_DEFINITI0N"); 
end  if; 


if  (TM.MATCH(TI4.T0KEN_LEFT_PAR£N))  then 
if  (TM.MATCH(TM.T0KEN_8RACK£TS))  then 
if  (TM.MATCH(TM.TOK£N_RIGHT_PAR£N))  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Generic  type  definition"); 
end  if;  --  if  match( token_right_paren ) 

else 


P4.SYNTAX_ERR0R("Generic  type  definition"); 
end  if;  —  if  match( token_brackets ) 

elsif  (TM.MATCH(TM.TOK£N_RANG£))  or  else  (TM.MATCH( TM. TOKEN_DIGITS) ) 
or  else  (TM.MATCH(TM.TOKEN_DELTA))  then 
if  (TM.MATCH(TM.TOKEN_BRACKETS))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Gener ic  type  definition"); 
end  if;  --  if  match( tokenbrackets ) 

elsif  (TM.MATCH(TM.TOKEN_ARRAY))  then 
if  (P3.ARRAY_TYPE  DEFINITION)  then 
return  (TRUE); 
else 


P4 . SYNTAX_ERROR( "Gener ic  type  definition"); 
end  if;  --  if  array_type_def in i tion 

elsif  (TM.MATCH(TM  TOKEN_ACCESS))  then 
if  (P3. SUBTYPE  INDICATION)  then 
return  (TRUE); 
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e  I  se 

P4 . SYNTAX_ERROR( "Generic  type  definition"); 
end  if;  --  if  subtype_indication 

else 

return  (FALSE); 

end  if;  --  if  match( token_lef tparen ) 

end  GENERIC_TYPE_DEFINITION; 


--  PRIVATE_TYPE_OECLARATION  — >  [limited  ?]  private 
function  PRIVATE_TYPE_DECLARATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.OUT_PUT("PRIVATE_TYPE_0ECLARATION“); 
end  if; 

if  (TM.MATCH(TM.TOKEN_LIMITED))  then 
nul  1  ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_PRIVATE))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  PRIVATE_TYPE_OECLARATION; 


--  SUBTYPE_OECLARATION  -->  identifier  is  SUBTYPE_INDICATION  ; 
function  SU8TYPE_DECLARATI0N  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("SUBTYPE_0ECLARATI0N"); 
end  if; 

if  (TM.MATCH(TM.TOKEN_IDENTIFIER))  then 
if  (TM.MATCH(TM.TOKEN_IS))  then 
if  {P3.SUBTYPE_INDICATI0N)  then 

if  (TI4.MATCH(TM.TOKEN_SEI4ICOLON))  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Subtype  declaration" ) ; 
end  if;  --  if  match( tokensemicol on ) 

else 

P4 . SYNTAX_ERROR( "Subtype  declaration"); 
end  if;  --  if  subtypeind icet ion 

else 

P4 . SYNTAX_ERROR( "Subtype  declaration" ) ; 
end  if;  --  if  match ( tokeni s ) 

else 

return  (FALSE); 
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-  if  match( token_tdenti f ier  ) 


end  if; 

end  SUBTYPEDECLARATION; 


--  TYPEOECLARATION  -->  identifier  [DISCRIMINANTPART  ?] 

[is  PRIVATE_rYP£_DECLARAriON  ?]; 

-->  identifier  [OISCRIMINANT_PART  ?] 

[is  TYPEOEE IMITIOH  ?]: 
function  TYPEOECLARATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  than 

P4 .0UT_PUT( "TYPE_OECLARATION" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_IDENTIFIER))  then 
if  (DISCRIMINANTPART)  then 
nul  1 ; 

end  if;  --  if  discriminantpart 

if  ( TM .MATCH( TM , TOKENIS) )  then  --  declaration  is  fulltype  if  'is 

if  (PRIVATE_TYPE_OECLARATION)  then 
null  ; 

elsif  ( TYPE_DEFINI TION)  then  --  present  else  incomp lete_type 

null; 
else 

P4 . SYNTAX_ERROR( "Type  declaration"); 
end  if;  --  if  type_def inition 

end  if;  --  if  match( token_i s ) 

if  (TM.MATCH(TI4,T0KEN_S£MIC0L0N))  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR("Type  declaration"); 
end  if;  if  match( token_semico1on ) 

else 

return  (FALSE); 

end  if;  --  if  match( token_ident i f ier ) 

end  TYPE_OECLARATION; 


--  DISCRIMINANTPART  -->  ( DISCRIMINANTSPEC I F ICATION 

[;  DISCRIMINANT  SPECIFICATION]"  ) 
function  DISCRIMINANTPART  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUTPUT! "DISCRIMINANTPART" ) ; 
end  if; 

if  (IM.MATCH(TM.TOXEN_LEFT_PAREN))  then 
if  (DISCRIMINANTSPECIFICATION)  then 
mhile  ( TM. MATCH! TM. TOKEN_SEMICOLON) )  loop 
if  not  (DISCRIMINANTSPECIFICATION)  then 
P4 . SYNTAXE RHOR( "Discriminant  part"); 


--  if  not  discriminantspecif ication 


end  if; 
end  loop; 

if  (TM.MATCH(TM.TOKEN_RIGHT_PAREN))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Discriminant  part"); 
end  if;  --  if  raatch{token_rii  iit_paren ) 

else 

P4 . SYNTAX_ERROR( "Discriminant  part"); 
and  if;  —  if  discriininant_specif ication 

else 

return  (FALSE); 

end  if;  --  if  iiiatch( token  lef t_paren ) 

end  DISCRIMINANT_PART; 


--  01SCRIMINANT_SPECIFICATI0N  -->  lOEMTIFIERLIST  :  NAME  [:=  EXPRESSION  ?] 
function  DISCRIMINANr_SPECIFICAriON  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("0ISCRIMINANT_SPECIFICATION"); 
end  if; 

if  (IDENTIFIER_LIST)  then 

if  (TM.MATCH(TM.TOKEM_COLQM))  then 

if  (P3.NAME)  then  --  check  for  type_iiiark 

if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 
null; 
else 

P4 . SYNTAX_ERROR( "Discriminant  specification" ) ; 
end  if;  --  if  expression  statement 

end  if;  --  if  match( token_ass ignment ) 

return  (TRUE); 
el  se 

P4 .SYNTAX_ERROR( "Discriminant  specification" ) ; 
end  if;  --  if  name  statement 

else 

P4 . SYNTAX_ERROR( "Discriminant  specification"); 
end  if;  --  if  match( token  col  on ) 

else 

return  (FALSE); 

end  if;  --  if  idem  if  ier_l  i  st  statement 

end  DISCRIMINANT_SPECIFICATION; 


--  TYPE^DEFINITION  --> 
--> 

--> 

> 


ENUMERAriON_TYPE_OEFlNniON 

INTEGER_TYPE_OEFINITION 

digits  FLOATING  OR_flXED_POINT_CONSTRAINT 

delta  FLOAnNG_OR_HXEO  POINT  CONSTRAINT 
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--)  array  ARRAY_TVP£_0£f INI riON 
-->  record  R£C0R0_TYPE_D£F1NITI0N 
-->  access  SUBTYPE_IN0ICATI0N 
-->  new  SUBrYP£_INDICATION 
function  TYPEOEF INI TION  return  boolean  is 
beg  1  n 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("TYPE_DEF INI TION"); 
end  if; 

if  (P4.ENUMERATION_TYPE_DEFINITION)  than 
return  (TRUE); 

elsif  (P3.INTEGER_TYPE_0EFINITI0N)  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOK£N_QIGITS))  or  else  ( TM.MATCH( TM . TOKEN_DELTA ) )  then 
if  (P3.fLOATING_OR_FIXEO^POINT_CONSTRAIMT)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Type  definition"); 

end  if:  --  floatingorf ixjd_point_constraint 

elsif  (TM.MATCH(TM,TOKEN_ARRAY))  then 
if  (P3.ARRAY_TYPE_0EFINITI0N)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR("Type  definition"); 
end  if;  --  if  array_type_def inition 

elsif  (TN.MATCH(TM.TOKEN_RECORO_STRUCTUR£))  then 
if  (RECORD_TYPE_OEFINITION)  then 
return  (TRUE): 
else 

P4.SYNTAX_ERROR( "Type  definition"); 
end  if;  --  if  record_type_def inition 

elsif  (TM.MATCH(TM.TOK£N_ACCESS))  or  else  ( TM .MATCH( TM. T0KEN_NEW) )  then 
if  (P3.SUBTYPE_INDICATION)  then 
return  (TRUE): 
else 

P4 . SYNTAX_ERROR( "Type  definition"); 
end  Tf;  --  if  subtype_indication 

else 

return  (FALSE); 
end  if; 

end  TYPE  DEFINITION; 


--  REC0R0_TYP£_0£FINITI0N  -  >  COMPONENTLIST  end  record 
function  RECORDTYPEOEFINITION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT  PUT( "RECORD_TYP£DEF INITION" ) ; 
end  if; 

if  (COMPONtNI  LIST)  then 
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if  (TM.MATCH(TM.TOKEN_END))  then 

if  (TM.MATCH(TM.TOKEN_RECORD_STRUCTURE))  then 
return  (TRUE): 
else 

P4 . SYNTAX_ERROR( "Record  type  definition"); 
end  if;  --  if  match(tolcen_record-structure) 

else 

P4 . SYNTAX_ERROR( "Record  type  definition"); 
end  if;  --  if  match(tol(en_end) 

else 

return  (FALSE); 

end  if;  --  if  coniponent_l  1st  statement 

end  RECORD_TYPE_DEFINITION: 


--  COMPONENTLIST  -->  [COMPONENTOECLARATIOK]*  [VAARI ANTPART  ?] 
-->  null  : 

function  COMPONENT_LIST  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "COMPONENT_LIST" ) ; 

end  if; 

while  (COMPON£NT_OECLARATION)  loop 
null ; 

end  loop; 

if  (VARIANT_PART)  then 
null; 

elsif  (TM,MATCH(rM.TOKEN_NULL))  then 
if  (T(4.MATCH(TM.T0K£N_SEMIC0L0N))  then 
null  ; 
end  if; 

end  if; 

return  (TRUE); 
end  COMPONENT^LIST; 


--  COMPONENTDECLARATION  IOENTIEIER_LIST  :  SUBTYPE_INDICATION 

[:=  EXPRESSION  ?]  ; 

function  COMPONENT  DECLARATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT( "COMPONENTDECLARATION" ) ; 
end  if; 

if  ( IDENTIFIER_LIST)  then 

if  ( TM. MATCH! TM, T0KEN_C0L0N))  then 
if  (PS.SUBIYPE^INDICATION)  then 

if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 

if  ( rM.MATCH( TM. rOKENSEMICOLON) )  then 
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return  (TRUE); 
else 

P4 ,SYNTAX_ERROR( "Component  declaration" ) ; 
end  if;  --  if  match( tokensemicolon ) 

else 

P4 . SYNTAX_£RROR( "Component  declaration" ) ; 
and  if;  --  if  expression  statement 

end  if;  --  if  match( tokenassignment) 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Component  declaration"); 
end  if;  --  if  match( tokensemicol on ) 

else 

P4 .SYNTAX_ERROR( "Component  declaration"); 
end  if;  --  if  subtype^indication  statement 

else 

P4 . SYNTAX_ERROR( "Componen t  declaration"); 
end  if;  --  if  match( tokencolon ) 

else 

return  (FALSE); 

end  if;  --  if  ident i f ier_l ist  statement 

end  COMPONENT_OECLARATION; 


--  VARIANT_PART  -->  case  identifier  is  [VARIANTJ+  end  case  ; 
function  VAfiIANT_PART  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( "VARIANT_PART" ) ; 
end  if; 

if  (TM.MArCH(TM.TOKEN_CASE))  then 

if  (TM.MATCH(TM.TOKEN_IOENTIFIER))  then 
if  (TM.I4ATCH(TM.T0KEN_IS))  then 
if  (VARIANT)  then 
while  (VARIANT)  loop 
nul  1 ; 
end  loop; 

if  (TI4.I4ATCH(TN.T0KEN_END))  then 
if  (TM.I4ATCH(TM.T0KEN_CASE))  then 

if  (TM.MATCH(TM.TOXEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR( "Variant  part"); 
end  if;  --  if  match( tokensemicol on ) 

else 

P4.SYNTAX_ERROR( "Variant  part"); 
end  if;  --  if  match( tokencase ) 

el  se 

P4.SYNTAXERR0R( "Variant  part"); 
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--  if  matcli(toiien_end) 


end  if; 
else 

P4.SYNTAX_ERR0R("Variant  part"); 
end  if; 
else 

P4.SYNTAX_ERR0R("Variant  part"); 
end  if; 
e1  se 

P4.SYNTAX_ERR0R( "Variant  part"); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  VARIANTPART; 


if  variant  statement 


if  match(token_is) 


if  iiiatch( token_ident if  ier) 


if  match(token_case) 


--  VARIANT  -->  when  CHOICE  [1  CHOICE]*  =>  C0MPONENT_LIST 
function  VARIANT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "VARIANT"): 
end  if; 

if  (TM.MATCH(TM.TOKEN_WHEN))  then 
if  {P3. CHOICE)  then 
while  (TM.MATCH(TM. TOKEN  BAR))  loop 


if  not  (P3. CHOICE)  then 
P4 . SYNTAX_ERR0R( "Variant" ) ; 
end  if; 
end  loop; 

if  (TM.MATCH(TM.TOKEN_ARROW))  th 
if  (C0MP0NENT_LIST)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Variant" ) ; 
end  if; 
else 

P4.SYNTAX_ERR0R( "Variant" ) ; 
end  if; 
else 

P4,SYNTAX_ERR0R( "Variant" ) ; 
end  if; 
else 

return  (FALSE); 
end  if; 
end  VARIANT; 


--  if  not  choice  statement 

n 


--  if  component_I ist  statement 


--  if  match(tokBn_arrow) 


--  if  choice  statement 


--  if  match( token  when ) 


WITH_OR_USE  CLAUSE  --> 
function  WITH  OR  USE  CLAUSE 


iden t i f ler  [ . 
return  boolean 


idem  1  f  ier  ]*  ; 
i  s 
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beg  1  n 

If  (P4.PRINT_CALLS)  then 
P4  .OUT_PUT(  '•WITH_0R_USE_CLAUSE"  ) ; 
end  if; 

If  (TM.MArCH(TM.TOKEN_IDENTIFIER))  then 
while  ( TM.MATCH(TM.TOKEN_COMMA))  loop 

if  not  (TM.MArCH(TM.TOKEN_tDENriFIER))  then 
P4.SYNTAX_ERR0R(”With  or  use  clause"); 
end  if; 
end  loop; 

if  (TM.MATCH(TM.TOI(EN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Wi th  or  use  clause"); 
end  if;  --  if  niatch( token_seiiiicolon ) 

else 

return  (FALSE); 

end  if;  --  if  match( token_identif ier) 

end  WITH_OR  USE_CLAUSE; 


--  FORMAL_PARr  -->  ( PARAME T£R_SPECI F ICATION  [;  PARAM£TER_SPECIFICATION]*  ) 

function  FORMAL_PART  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( "FORMAL_PART" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_LEfT_PAR£N))  then 
if  (PARAMET£R_SPECIFtCATION)  then 
while  (TM.MATCH(TM.TOXEN_S£MICOLON))  loop 
if  not  (PARAM£T£R_SPECIFICATrON)  then 
P4 .SYMTAX_ERROR( "Formal  part"); 

end  if;  --  if  not  paranieter_specif ication 

end  loop; 

if  (TM.MATCH(TM.TOK£N_RIGHT_PAREN))  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R("Formal  part"); 

end  if;  --  if  niatch(  token_right_paren ) 

else 

P4.SYNTAX_ERR0R("Formal  part"); 

end  if;  --  if  parameterspecif ication 

e  I  se 

return  (FALSE); 

end  if;  --  if  match( token_lef t_paren) 

end  FORMAL_PART; 
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--  IDENTIFIER_DECLARATION  -->  lOENTI F [ERLIST  ;  IO£NTIFIER_OECLARATIOM_TAIL 
function  IDENTIFIER_DECLARATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4,0UT_PUT("IDENTIFIER_DECLARATI0N'’); 
end  if; 

if  ( IDENTIFIER_LIST)  then 

if  (TM.MATCH(TM.TOKEN_COLON))  then 
if  (IDENTIFIER_DECLARATION_TAIL)  than 
return  (TRUE); 
else 

P4 , SYNTAX_ERROR( "Identifier  declaration"); 
end  if;  --  if  identifier! 1st 

else 

P4 . SYNTAX_ERROR( "Identifier  declaration"); 
end  if;  --  if  match( toXencolon ) 

else 

return( FALSE ) ; 

end  if;  --  if  identifier! ist 

end  IDENTIFIER_DECLARATION; 


--  1DENTIFIER_0ECLARATI0N_TAIL  --> 

--> 

--> 

function  IDENTIFIER  DECLARATION  TAIL 


exception  EXCEPTION_TAIL 
constant  CONSTANT_T£RM 
array  ARRAY_TYPE_D£f INITION 
[;=  EXPRESSION  ?]  ; 

NAME  IOEMTIfI£R_TAlL 
return  boolean  is 


begin 


if  {P4.PR1NT_CALLS)  then 

P4.0UT_PUT("I0ENTIFIER_0ECLARATI0N_TA1L"); 
end  if ; 


if  (TM.MATCH(TM.T0KEN_EXCEPT10N))  then 
if  (EXCEPTION_TAIL)  then 
return  (TRUE); 
else 


P4 . SYNTAX_ERROR( " Ident i f ier  declaration  tail"); 
end  if;  --  if  exception  tail  statement 

elsif  (TM.MArCH(TM.TOKEN_COMSTANT))  then 
if  (CONSTANTTERM)  then 
return  (TRUE); 
e  I  se 


P4 . SYNTAX_ERROR( " Ident 1 f ler  declaration  tail"); 
end  if;  -  if  constantterm  statement 

elsif  (TM.MATCH(TM.TOKEN_ARRAY))  then 
if  (P3.ARRAY_TYPE_DEFINITI0N)  then 

if  ( IM.MArCH(TM. TOXENASSIGNMENT ) )  then 
if  (P3. EXPRESSION)  then 
null  ; 


e  I  se 
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P4.SYNIAX_£RR0R( "Identifier  declaration 
end  if;  -if 

end  if;  --if 

el  se 

P4.SYNTAX_ERR0R( " Identif ier  declaration  tail 
end  if;  --  if 

if  {TM.MATCH( TM.TOKEN_S£MICOLON))  then 
return  (TRUE); 
el  se 

P4 , SYNTAX_ERROR( " Identif ier  declaration  tail 
end  if;  --if 

elsif  (P3.NAME)  then 

if  (IDENTIFlER_rAIL)  then 
return  (TRUE); 
else 

P4 .SYNTAX_£RROR( " Identif ier  declaration  tail 
end  if;  --  if 

else 

return  (FALSE); 

end  if;  --  if 

end  IDENTIFIEROECLARATIONTAIL; 


--  £XCEPTION_TAIL  -->  ; 

-->  renames  NAME  ; 

function  EXCEPTION_TAIL  return  boolean  is 
beg  in 

if  (P4.PHINT_CALLS)  then 
P4.0UT_PUT( "EXCEPTION_TAIL"); 
end  i  f ; 

if  ( TM.MATCH( TM. IOXEN_SEMIC0L0N))  then 
return  (TRUE); 

elsif  (TM,MATCH(TM,TOKEN_RENAMES))  then 
if  (P3.NAME)  then 

If  (TM.MATCH( TM.TOKENSEMICOLON))  then 
return  (TRUE); 
e  I  se 

P4 . SYNTAX_ERROR( "Exception  tail"); 
end  if;  --if 

else 

P4 . SYNTAX_ERROR( "Exception  tail"); 
end  if;  --  if 

else 

return  ( FALSE  )  ; 
end  if; 

end  EXCEPTIONTAIL ; 


tail"); 

expression  statement 
match( toXenass ignmen t ) 

arraytypedef in  1 1 ion 


■); 

match(  token_seroicolo(i ) 


1  den t i Tier  tail 


match ( toXenexception ) 


match(toXen_semicolon) 


name  statement 


if  match( toXen  semicolon ) 


--  EXCEPTION_CHOICE  -->  NAME 

-->  others 

function  EXCEPTION_CHOICE  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .0UT_PUT( "EXCEPTION_CHOICE" ) ; 
end  if; 

if  (P3.NAME)  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_OTHERS))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  EXCEPTION_CHOICE; 


--  CONSTANTTERM  array  ARRAYTYPEOEFIMITION  [ ; =  EXPRESSION  ?]  ; 

-->  :=  EXPRESSION  ; 

-->  NAME  IDENTIflERTAIL 
function  CONSTANT_TERM  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT( "CONSTANI_TERM” ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_ARRAY))  then 
if  (P3.ARRAY_TYPE_DEFINITI0N)  then 

if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  {P3. EXPRESSION)  then 
null ; 
else 

P4 , SYMTAX_ERR0R( "Constant  terra" ) ; 
end  if;  --  if  expression  statement 

end  if;  --  if  match( token_ass ignment ) 

else 

P4 . SYNrAX_ERROR( "Constant  term" ) ; 

end  if;  --  if  arraytype  definition 

if  (TM.MATCH(TM.TOKEM_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNrAX_ERROR( "Constant  terra" ) ; 

end  if;  --  if  match( token_seraicolon ) 

elsif  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
e  i  se 

P4 . SYNTAX_ERROR( "Constant  term"); 

end  if;  --  if  match(tOken  semicolon) 

else 
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if  expression  statement 


P4 . SYNTAX_ERROR( "Constant  term" ) ; 
end  if; 

elsif  (P3.NAME)  then 

if  (IDENTIf IER_TAIL)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Constant  terra" ) ; 
end  if;  --  if  identif ier_tail  statement 

else 

return  (FALSE); 

end  if;  --  if  match( toXen_array ) 

end  CONSTANTTERM; 


--  IDENTIFIER_TAIL  -->  [CONSTRAINT  ?]  [:=  EXPRESSION  ?]  ; 

-->  [renames  NAME  ?]  ; 
function  lOENTIFIERTAIL  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("IDENTIFIER_TAIL"); 
end  if; 

if  (P3. CONSTRAINT)  then 
null  ; 

end  if;  --  if  constraint  statement 

if  (TM.MATCH(TM.TOKEN_RENAMES))  then 
if  (P3.NAME)  then 
null; 
else 

P4.SYNTAX_ERR0R( "Identifier  tail"); 
end  if;  --  if  name  statement 

end  if;  --  if  raatch( token_renames ) 

if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 
null  ; 
else 

P4 . SYNTAX_ERROR( "Identifier  tail"); 
end  if;  --  if  expression  statement 

end  if;  --  if  match( token_ass ignraent ) 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
e  1  se 

return  (FALSE); 

end  if;  --  if  match( token_semicolon) 

end  lOENTIFIERTAIL; 


--  PARAMETER_SPECIFICAT10N  -->  IDENTIFIER  LIST  :  MODE  NAME  [:-  EXPRESSION  ?] 
function  PARAME TERSPEC I F ICA r ION  return  boolean  is 
beg  in 
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if  (PA.PRINTCALLS)  then 
P4.0UT_PUT(  '’PARAMETER_SPECIFICATION"); 
end  if; 

if  { IDENTIFIER_LIST)  then 

if  (TM.MATCH(TM.TOKEN_COLON))  then 
if  (MODE)  then 

if  (P3.NAME)  then  --  check  for  type_(nark 

if  (TM.MATCH(TM.T0KEN_ASS1GNMEMT))  then 
if  (P3. EXPRESSION)  then 
null ; 
else 

P4 . SYNTAX_ERROR( "Parameter  specif ication" ) ; 
end  if;  --  if  expression  statement 

end  if;  --  if  match( token_assignment) 

return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Parameter  specification’ ) ; 
end  if;  --  if  name  statement 

else 

P4 . SYNTAX_ERROR( "Parameter  specification" ) ; 
end  if;  --  if  mode  statement 

else 

P4 . SYNTAX_ERROR( "Parameter  specification"); 
end  if;  --  if  match( token_col on ) 

else 

return  (FALSE); 

end  if;  --  if  identif ier_1 ist  statement 

end  PARAMETER_SPECIFICATION; 


--  IDEN f  1  FIER_LISr  ■-->  identifier  [,  identifier]* 
function  IDENTIFIER_LIST  return  boolean  is 
TEMP_TOXEN  :  TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

LOCATION  :  natural ; 
begin 

if  (P4,PRINT_CALLS)  then 

P4.0UT_PUT("IDENTIFIER_LISr"): 
end  if; 

if  (TM.MATCH(TM.TOKEN_IOENTIFIER))  then 

LOCATION  :=  COOEBLOCKER . CURRENr_COOE_BLOCK_NUMBER ; 

TM.MATCHED_TOKEN( TEMPTOKEN) ; 

SYMBOL_TABLE. INSERT_SYM_TAB(TEMP_TOXEN.LEXEME( 1. . TEMPTOKEN . LEXEMESI ZE ) , 

SYMBOL_TABLE.OBJECT_DECLARATION_TAG,  LOCATION) ; 
while  (TM.MATCH(TM.TOKEN_COMMA))  loop 
if  (TM.MATCH(TM.TOKEN_IOENIIFIER))  then 
TM.MATCHEO_TOKEN( TEMPTOKEN) ; 

SYMBO. _TABl: . I NSERT_SYM_TAB( TEMPTOKEN. lexeme ( 1 . . TEMPTOKEN . LEXEME_SI ZE ) , 

SYMB0L_TABLE.0BJECT_DECLARAT10N_TAG, 

LOCATION); 

else 
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P4.SYNTAX_EftR0R(" Identifier  list"); 
end  if;  --  if  not  match( token_identi f er )  statement 

end  loop; 
return  (TRUE); 
else 

return  (FALSE); 

end  if;  --  if  match( token_ident i f ier)  statement 

end  IOENTIFIER_LIST; 


--  MODE  -->  [in  ?] 

-->  in  out 
-->  out 

function  MODE  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("M00E"); 

end  if; 

if  (TM.MATCH(rM.TQKEN_IN))  then 
if  (TM.MATCH(rM.TOKEN_OUT))  then 
null; 
end  if; 

elsif  (TM.MATCH(TM.TOkEN_OUT))  then 
null ; 

end  if; 

return  (TRUE); 
end  MODE; 


--  DESIGNATOR  -->  identifier 

-->  string^l iteral 
function  DESIGNATOR  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT( "DESIGNATOR" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_IOENTIFIER))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_STRING_LITERAL))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  DESIGNATOR; 


--  SIMPLE  STATEMENT  --> 
-  > 


null  ; 

ASSIGNMENI  OK. PHOCEDURECALL 
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-->  exit  EXIT_STATEMENT 
-->  return  R£TURM_STAIEMENT 
-->  goto  GOTO_STATEMENT 
delay  DELAy_STATEM£NT 
-->  abort  ABORT_STATEMEMT 
-->  raise  RAISE_STATEMEMr 
function  SIMPLE_STATEMENT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "SIMPLE_STATEMENT" ) ; 

end  if; 

if  (TM.MATCH(TM.TOKEN_NULL))  than 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
COOE_BLOCKER . INCREMENTSTATEMENTCOUMT ; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple  statement' ) ; 
end  if; 

elsif  (ASSI6NMENT_0R_PR0CEDURE_CALL)  then  --  includes  a  check  for  a 
return  (TRUE);  --  code  statement  and  an 

elsif  (TM.MATCH(TM.TOKEN_EXIT))  then  --  entry  call  statement, 

if  (P3.EXIT_STArEM£NT)  then 

CODE_BLOCKER.INCREMENT_SIATEMENT_COUNT; 
return  (TRUE): 
else 

P4.SYNTAX_£RR0R( "Simple  statement" ) ; 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_RETURN))  then 
if  (P3.RETURN_SrATEMENT)  then 
C00E_BL0CKER . INCREMENT_STAT£MENT_COUNT ; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple  statement" ) ; 
end  if; 

elsif  (TM.MATCH(Ti4.T0KEN_G0T0) )  then 
if  (P3.G0T0_STATEMENT)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple  statement" ) : 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_DELAY))  then 
if  (P3.DELAY_STATEMENT)  then 

C00E_BL0CKER . INCREMENTSTATEMENTCOUNT ; 
return  (TRUE): 
else 

P4 . SYNTAX_ERROR( "Simple  statement" ) : 
end  i f ; 

elsif  (TM.MATCH(TM.T0KEN_AB0R1))  then 
if  (PS.ABORTSTATEMENT)  then 
CODE  BLOCKER. INCREMENT  SIATEMENTCOUNI ; 
return  ( TRUE  )  ; 
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else 

P4 . SYNTAX_ERROR( "Simp  1 e  statement" ) ; 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_RAISE))  then 
if  (P3.RAISE_STATEMENf )  then 
COOE_BLOCKER . INCREMENT_STATEMEN  fCOUNT ; 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Simple  Statement"); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  SIMPLE_STATEMENT; 


--  ASSIGNM£NT_OR_PROCEDURE_CALL  -->  NAME  :=  EXPRESSION  ; 

-->  NAME  ; 

function  ASSIGNM£NT_OR_PROC£DURE_CALL  return  boolean  is 
SEARCHPOINTER  :  SYMBOL_TABLE .SYM_TAB_ACCESS; 

S£ARCH_TOKEN  :  TOKEN_SCANNER . TOKEN_RECORO_TYPE ; 

LOCATION_ONE  :  positive; 

use  SYMBOL_TABLE : 

begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("ASSIGNMENT_0R_PR0CEDURE_CALL"); 
end  if; 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 
if  (P3.NAME)  then 

if  (TM.MATCH(TM.TOKEN_ASSIGNMENT))  then 
if  (P3. EXPRESSION)  then 

TM.MATCHED_TOKEN(SEARCH_TOKEN); 

SEARCH_POINT£R  ;=  SYMBOL_TABLE , RETRIEVE_SYM; 
if  ((SEARCH_POINTER  /=  null)  and  then 

(SEARCH_POINTER.TAG_TYPE  =  SYMBOL_TABLE . FUNCTION_DECLARATION_TAG ) )  then 
LOCATION_ONE  ;=  COOEBLOCKER . CUHR£NT_COOE_BLOCK_NUMBER ; 

CODE_BLOCKER. INCREMENTSTATEMENTCOUNT; 

C00E_BL0CX£R . EXI T_C00E_8L0CK( SEARCHTOKEN . SOURCE ) ; 
NET_GENERATOR.CALL(LOCATION_ONE.  SEARCHPOINTER) ; 

COOE_BLOCKER . ENTER_C00E_BL0CK( SEARCHTOKEN . SOURCE ,  " " ) ; 
e  1  se 

COOE_BLOCKER. INCREMENT  STATEMENTCOUNT; 
end  i f ; 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
SYMBOLIABLE .R£STORt_CURRENr_ENTRY; 

return  (TRUE);  --  parsed  an  assignment  statement 

else 

P4 . SYNrAX_ERROR( " Ass ignment  or  procedure  call"); 
end  if;  --  if  match( tokensemicolon) 

u  I  se 
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P4 .SYNTAX_ERROR( " Ass ignment  or  procedure  call"); 
end  if;  --  if  expression  statement 

elsif  (TM.MATCH(TM.TOKEM_SEMICOLQN))  then 
TM . MATCHED_TOKEN( SEARCH_TOKEN) ; 

SEARCH_POIhTER  :=  SYMBOLTABLE .R£TRIEVE_SYM; 
if  ((SEARCH_POINTER  /=  null)  and  then 

(SEARCH_POINTER.TAG_TYPE  =  SYMBOL_TABLE .PROCEOURE_0£CLARATION_TAG) )  then 
LOCATION_ONE  :=  COOE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 
COOE_BLOCKER.INCREMENT_STATEMENT_COUNT; 

COOE_BLOCICER .  EXIT_COO£_BLOCK(SEARCH_TOKEN .  SOURCE ) ; 
NET_GENERATOR.CALL(LOCATION_ONE,  SEARCH_POINT£R) ; 

CODE_BLOCKER . ENTER_COOE_BLOCK( SEAfiCH_TOK£N . SOURCE ,  " " ) ; 
elsif  ((SEARCHPOINTER  /=  null)  and  then 
(SEARCH_POINTER.TAG_TYP£  =  SYMBOL_TABLE.EMTRY_TAG))  then 
L0CATI0N_0N£  :=  C00E_8L0CKER.CURREMT_C0DE_BL0CX_NUMBER; 
COOE_BLOCXER.rNCR£MENT_STATEMENT_COU»IT; 

COOE_BLOCKER . EXI T_COOE_BLOCK( SEARCH^TOXEN . SOURCE ) ; 
NET_GENERATOR.£NTRY_CALL(LOCATION_OME.  SEARCH_P0INTER); 

COOE_BLOCKER . ENT£R_COOE_BLOCX(SEARCH_TOKEN . SOURCE .  " " ) ; 
end  if; 

SYKIBOL_TABL£.R£STORE_CURRENT_ENTRY; 

return  (TRUE);  --  parsed  a  procedure  call  statement 

else 

P4.SYNTAX_ERR0R( "Assignment  or  procedure  call"); 
end  if;  •*  if  mateh(token_assignment) 

else 

SYMBOL_TABLE.RESTOR£_CURRENr_ENTRY; 
return  (FALSE); 

end  if;  --  if  name  statement 

end  ASSIGNMENT_OR_PROC£DURE_CALL ; 


--  LABEL  -->  <<  identifier  >> 

function  LABEL  return  boolean  is 
STARTTOKEN  :  TOKEN_SCAMNER . TOKEN_RECORD_TYPE ; 

LOCATION_ONE  ;  positive; 

LOCATIONTWO  :  positive; 
use  SYMBOL_TABLE ; 
begin 

if  (PA.PRINTCALLS)  then 
P4,0UT_PUT("LABEL"); 
end  if; 

if  (TM.I4ATCH(TM.T0XEN_LEFT_BRACKET))  then 
if  (TM.MATCH(TM.TOXEN_IDENriFIER))  then 
rM.MATCHED_rOKEN(START_TOKEN); 
if  (TM.MATCH(TM.TOKEN_RIGHT_BRACXET))  then 

if  (COOEBLOCXER. CURRENT  STAIEMENTCOUNT  /=  0)  then 

LOCATION  ONE  :=  CODE  BLOCKER .CURRENT_COOE_BLOCX_NUMBER ; 

CODE  BLOCKER. EX  IT  CODE  BL0CK(START_T0KEN. SOURCE); 

CODE  BlOCKEH. ENTER  CODE  BLOCK( SIARI  TOKEN . SOURCE ,  "LABELLED  BLOCK") 
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LOCATION_TWO  COOE_BLOCKER . CURRENr_COD£_BLOCK_NUMBER ; 

COOE_BLOCKER . INCREMENT  _STArEMENT_COUMI ; 

NET_GENERATOR.CONNECT_BLOCKS(LOCATION_ONE.  LOCAnON_TWO) ; 
else 

CODE_BLOCKER.DELETE_COOE_8LOCK_EMTER: 

C00E_BL0CKER.ENTER_C0DE_8L0CK(START_T0KEN. SOURCE.  "LABELLED  BLOCK"); 
C00E_8L0CKER . INCREMENT_STAIEM£NT_COUMT ; 

LOCATION_TWO  ;=  CODE_BLOCKER .CURRENT_COO£_BLOCK_NUMBER ; 
end  if ; 

if  (SYMBOL_TABLE.FIND_KEY(START_TOKEM.LEXEM£(l. . 
START_TOKEN.LEXEM£_SIZE))  =  null)  then 
SYMBOL_TABLE . I NS£RT_SYM_TAB( START_TOKEN . 

L£XEME( 1 . .STA8T_T0KEM . LEXEME_SI ZE ) , 
SYMBOL_TABLE . LAB£L_NAME ,  LOCATION_TWO ) ; 

else 

SYMBOL_TABLE.U('DATE_SYM_rAB(LOCATION_TWO); 
end  if; 

return  (TRUE); 
el  se 

P4.SYNTAX_ERROR("Label"); 

end  if;  --  if  niatch( toKen_ri9ht_bracKet) 

else 

P4 .SYNTAX_ERROR( "Label " ) ; 

end  if;  --  if  niatch( token_ident i f ier) 

else 

return  (FALSE); 

end  if;  --  if  iiiatch(  token_lef  t_bracket) 

and  LABEL; 


--  £NTRY_DECLARATION  -->  entry  identifier  [(OISCRETE_RANGE )  ?] 

[FORMAL_PART  ?]  ; 

function  ENTRY_OECLARATION  return  boolean  is 
START_TOKEM  :  TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "ENTRYOECLARATION" ) ; 
end  if; 

if  (TM.MATCH(TM,TOKEN_ENrRY))  then 

if  (TM.MATCH(TM.TOKEN_IDENTIFIER))  then 
TM.MATCHED_TOKEN(START_TOKEN); 

SYM60L_TABLE. IMSERT_SYM_TA8( START_TOKEN. LEXEME ( 1 . . 

STARTTOKEN.LEXEMESIZE),  SYMBOL_TABLE . ENTRYTAG,  0); 
SYMBOL_TABLE.INSERT_SYM_TAB("END",  SYMBOL_TABLE . LABEL_NAME .  0); 
if  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
if  (P3.0ISCRETE_RAMGE)  then 

if  ( rM.MATCH(TM.TOKEN_RIGHT_PAREN))  then 
null; 
else 

P4  SYNIAX  tRHOR( "Entry  declaration" ) ; 
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if  match( token_right_paren ) 


end  if; 
else 

P4 . SYNTAX_ERROR( "Entry  declaration"); 
end  if;  --  if  di screte_range  statement 

end  if;  --  if  match( token_left_paren ) 

if  (FORMAL_PART)  then 


nul  1  ; 
end  if; 

if  (TH.MATCH(TM.T0KEM_SEI4IC0L0N))  then 
rM.MATCHED_TOKEN(START_TOKEN); 
SYMBOL_TABLE . EXI T_SC0PE ; 
return  (TRUE); 
else 

P4,SYNTAX_ERR0R( "Entry  declaration"); 
end  if ; 
else 

P4 . SYNTAX_ERROR( "Entry  declaration"); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  ENTRYOECLARATION; 


if  formal_part  statement 


if  matcn( tolcen_semico1on ) 


if  match( tokenidentif ier) 


if  match( token_entry ) 


--  REPRESENTATION_CLAUSE  -->  for  NAME  use  record  RECORD_REPRESENTATION_CLAUSE 

-->  for  NAME  use  [at  ?]  SIMPLE_EXPRESSION ; 
function  REPR£SENTATION_CLAUS£  return  boolean  is 
begin 

if  (P4,PRINT_CALLS)  then 
P4.0UT_PUT("REPRESENTATI0N_CLAUSE"); 

end  if; 

if  (TM.MAICH(TM.TOKEN_FOR))  then 
if  (P3.NAME)  then 

if  (TM,MATCH(TM.TOKEN_USE))  then 
if  (TM.MATCH(TM.TOKEN_RECORO_STRUCTUflE))  then 
if  (RECORD_REPRESENTATION_CLAUSE)  then 
return  (TRUE): 
else 

P4 , SYNTAX_ERROR( "Representation  clause"); 
end  if;  --  if  recordrepresentationclause 

elsif  (TM.MArCH(TM.TOKEN_AT))  then 
if  (P3.SIMPLE_EXPRESSI0N)  then 

if  (TM.MATCH(TM.rOKEN_SEMICOLON))  then 
return  (TRUE); 
e  I  se 

P4 . SYNTAX_ERROR( "Representation  clause"); 
end  if;  -  if  match( tokensemicolon) 

e  I  se 

P4  SYNTAX  ERRORT "Representat ion  clause"); 
end  if;  if  s imp  1 e_e «p res s i on  statement 
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elsif  (P3.SIMPLE_EXPRESSI0N)  then 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SVNTAX_ERROR( "Representation  clause” ) ; 
end  if;  --  if  raatcn( tokensemicol on ) 

else 

P4 . SYNTAX_ERROR( "Representation  clause” ) ; 
end  if;  —  if  matcft(token_record) 

else 

P4 .SYNTAX_ERROR{” Representation  clause”) ; 
end  if;  --  if  iiiatch( token_use ) 

else 

P4 . SYNTAX_ERROR( "Representation  clause”); 
end  if;  --  if  name  statement 

else 

return  (FALSE); 

end  if;  --  if  matcn( tokenfor) 

end  REPRESENTATION_CLAUSE; 


--  RECORO_R£PR£SENTATION_CLAUSE  -->  [at  mod  SIMPLE_EXPR£SSION  ?] 

[NAME  at  SIKIPLE  EXPRESSION  rangr  RANGES]* 
end  record  ; 

function  REC0R0_R£PRES£NTATI0N_CL4  S£  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( -RECORD. REPR£SENTATION_CLAUS£’ ) ; 
end  if; 

if  (TM.MArCH(TM.T3KEN_AT))  then 
if  ( TM. MATCH ; iM. T0KEN_M00) )  then 
if  (P3.SIMPLE_EXPRESSI0N)  then 
nul  1  ; 
else 

P4 .SYMTAX_ERROR( "Record  representation  clause”); 
end  if;  --  if  simpleexpression 

else 

P4 . SYNTAX_EflROR( "Record  representation  clause'); 
end  if;  --  if  match( token.mod) 

e (d  if;  --  if  malch( tokenat ) 

while  (P3.NAME)  loop 

if  (TM.MATCH(TM.TQKEN_AT))  then 
if  (P3.SIMPLE_EXPRESSI0N)  then 

if  (TM.MATCH(TM.TOKEN_RANGE))  then 
if  (P3. RANGES)  then 
null; 
else 

P4 . SYNTAX_ERROR( "Record  representation  clause”); 
end  if;  --  if  ranges  statement 

e  I  se 
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P4 . SYNTAX_ERROR( "Record  representation  clause"); 
end  if;  --  if  match( token_range ) 

else 

P4 . SYNTAX_ERROR( "Record  representation  clause"); 

end  if;  --  if  siiiiple_expression 

else 

P4 . SYNTAX_ERROR( "Record  representation  clause"); 
end  if;  --  if  match( token_at ) 

end  loop; 

if  (TM.MATCH(TM.TOKEN_ENO))  then 

if  (TM.MATCH(TM.TOKEN_RECORD_STRUCTURE))  then 
if  (TM.MATCH(TM.TOXEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERROR( "Record  representation  clause"); 

end  if;  --  if  match( token_semicolon ) 

else 

P4 . SYNTAX_ERROR( "Record  representation  clause"); 
end  if;  --  if  match( token_record_structure) 

else 

return  (FALSE); 

end  if;  --  if  match( token_end) 

end  RECORD_REPRES£NTATION_CLAUSE ; 

end  PARSER_a; 
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TITLE: 


AOAFLOW 


--  MODULE  NAME:  PACKAGE  PARSER_3 

--  FILE  NAME:  PARSER3.ADS 

--  DATE  CREATED:  20  FEB  88 

--  LAST  MODIFIED:  28  APR  88 

--  AUTHOR(S):  LT  ALBERT  J.  GRECCO,  USN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY: 

LCDR  JEFFREY  L.  NIEDER.  USN 
LT  KARL  S.  FAIRBANKS,  JR..  USN 
LCDR  PAUL  M.  HER2IG,  USN 

DESCRIPTION:  This  package  defines  the  functions 

that  make  up  the  baseline  productions  for  a  top-down, 
recursive  descent  parser. 


package  PARSER_3  is 

function  SU8TYPE_IN0ICAT!0N  return  boolean; 

function  ARRAY_TYPE_DEFINITION  return  boolean; 

function  CHOICE  return  boolean; 

function  ITERATION_SCHEME  return  boolean; 

function  LOOP_PARAMETER_SPECIEICATION  return  boolean; 

function  EXPRESSION  return  boolean; 

function  RELATION  return  boolean; 

function  RELATION_TAlL  return  boolean; 

function  SIMPLE_EXPRESSION  return  boolean; 

function  SIMPLE_EXPRESSION_TAIL  return  boolean; 

function  TERM  return  boolean; 

function  FACTOR  return  boolean; 

function  PRIMARY  return  boolean; 

function  CONSTRAINT  return  boolean; 

function  FLOATING_OR_FIXED_POINT_CONSTRAINT  return  boolean; 

function  INDEX_CONSTRAINT  return  boolean; 

function  RANGES  return  boolean; 

function  AGGREGATE  return  boolean; 

function  COMPONENTASSOCIATION  return  boolean; 

function  ALLOCATOR  return  boolean; 

function  NAME  return  boolean; 

function  NAMETAIL  return  boolean; 

function  LEFTPARENNAME  TAIL  return  boolean; 

function  ATTRIBUTEOEC  NATOR  return  boolean; 

function  INTEGER_TYPE_,,  IFINI  T  ION  return  boolean; 

function  DISCRETE  RANGE  return  boolean: 

function  E X  I r _S fA I EMEN  I  return  boolean; 
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function  RETURN_STATEMENT  return  boolean 
function  G0T0_STATEMENT  return  boolean; 
function  DELAYSTATEMENT  return  boolean; 
function  ABORTSTATEMENT  return  boolean; 
function  RAISE_STATEMENT  return  boolean; 
end  PARSERS; 
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TITLE  : 


ADA FLOW 


--  MODULE  NAME:  PACKAGE  PARSER_3 

--  file  NAME:  PARSERS. ADB 


--  DATE  CREATED:  20  FEB  88 
--  LAST  MODIFIED:  28  APR  88 


--  AUTi'OR(S):  LT  ALBERT  J.  GRECCO.  USN 


--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY; 

LCDR  JEFFREY  L.  NIEOER,  USN 
LT  KARL  S.  FAIRBANKS,  JR.,  USN 
LCOR  PAUL  M.  HERZIG,  USN 


DESCRIPTION:  This  package  implements  the  functions 

that  make  up  the  baseline  productions  for  a  top-down, 
recursive  descent  parser.  Each  function  is  preceded 
by  the  grammar  productions  they  are  implementing. 


with  PAfiSER_4,  TOKEN_MATCHER.  TOKEN_SCANNER .  COOEBLOCKE R , 
SYM80L_TABLE,  NE T_GENE RA TOR ; 

package  body  PARS£R_3  is 

package  TM  renames  T0KEN_MATCHER; 
package  P4  renames  PARSER_4; 

--  SU8TYPE_INDICAII0N  -->  NAME  [CONSTRAINT  ?] 
function  SUBTYPE_IN01CAT ION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.OUT_PUT("SUBTYPE_IN0ICATION"): 
end  if; 

if  (NAME)  then  --  check  for  typemark 

if  (CONSTRAINT)  then 
null  ; 
end  if; 

return  (TRUE); 
e  1  se 

return  (FALSE); 
end  if; 

end  SUBTYPE  INDICATION; 


-  ARRAY_TYPE_DtFINI riON  >  ( INDE X  CONSTRAIN!  of  SUBTYPE  INOICAI ION 

-  this  function  parses  both  constrained  and  unconstrained  arrays 
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function  ARRAY_TYPE_DEFINI TION  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("ARRAY_TYPE_DEFINITI0N“); 
end  if; 

if  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
if  ( INOEXCONSTRAINT)  then 

if  (TM.MATCH(TM.TOKEN_OF))  then 
if  (SUBTYPE_INOICATION)  then 
return  (TRUE); 
else 

P4 .SYNTAX_ERR0R( "Array  definition”); 
end  if;  --  if  subtype_indication 

else 

P4 . SYNTAX_ERROR( "Array  definition"); 
end  if;  --  if  n!atch(  token_of ) 

else 

P4 .SYNTAX_ERROR( "Array  definition" ) ; 

end  if;  --  if  indexconstraint  statement 

else 

return  (FALSE); 

end  if;  --  if  match( token_1ef t_paren ) 

end  ARRAY_TYPE  DEFINITION; 


--  CHOICE  EXPRESSION  [ . . SIMPLE_EXPRESSION  ?] 

-->  EXPRESSION  [CONSTRAINT  ?] 

-->  others 

function  CHOICE  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("CH0ICE"); 
end  if; 

if  (EXPRESSION)  then 

if  ( TI4.MATCH( TM . T0kEN_RANGE_00IS) )  then  -  check  for  d i sere te_range 
if  (SIMPLE_EXPRESSION)  then 
null; 
else 

P4.SYNTAX_ERR0R( "Choice"); 

end  if;  --  if  simpleexpression  statement 

elsif  (CONSTRAINT)  then 
null; 

end  if;  --  if  match  tokenrangedots 

return  (TRUE); 

elsif  (TM.MATCH( TM. TOkENOTHERS))  then 
return  (TRUE); 
e  I  se 

return  (FALSE); 
end  if; 
end  CHOICE  ; 
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--  ITERATION_SCHEME  -->  while  EXPRESSION 

-->  for  LOOPPARAMETERSPECIfICATION 
function  ITERATIONSCHEME  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("ITERATI0N_SCHEME"); 
end  if; 

if  (TM.MATCH(TM.T0KEN_WHILE))  then 
if  (EXPRESSION)  then 
return  (TRUE): 
else 

P4.SYNTAX_ERR0R( "Iteration  scheme"); 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_FOR))  then 
if  (LOOP_PARAMETER_SPECIFICATION)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Iteration  scheme" ) ; 
end  if; 
else 

return  (FALSE); 
end  if; 

end  ITERAIION_SCHEME: 


--  LOOP_PARAMET£R_SPECIf ICATION  -->  identifier  in  [reverse  ?]  DISCRETE_RANGE 
function  LOOP_PARAMETER_SPECIFICATION  return  boolean  is 
begin 

if  (P4,PRINT_CALLS)  then 
P4.0UT_PUT( "LOOP_PARAMETER_SP£CIFICATION"); 
end  if; 

if  (TI4.HATCH(TM.T0KEN_IDENTIFIER))  then 
if  (TM.MATCH(TM.TOKEN_IN))  then 

if  (TM.MATCH(TM,TOK£N_REVERSE))  then 
null  ; 

end  if;  --  if  roatch( tokenreverse ) 

if  (OISCRETE_RANGE)  then 
return  (TRUE); 
else 

P4 .SYNrAX_£RROR( "Loop  parameter  specification"); 
end  if;  --  if  discreterange  statement 

else 

P4 . SYNrAX_ERROR( "Loop  parameter  specification"); 
end  if;  --  if  match( token_ in ) 

e  I  se 

return  (FALSE); 


131 


--  if  raatch( token_identif ler) 


end  if; 

end  LOOP_PARAMETER_SPECIFICATION; 


--  EXPRESSION  -->  RELATION  [RELATION_TAIL  ?] 
function  EXPRESSION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "EXPRESSION" ) ; 

end  if; 

if  (RELATION)  then 

if  (RELATION_TAIL)  then 
null; 

end  if;  --  if  rel at ion_tai 1  statement 

return  (TRUE); 

else 

return  (FALSE); 

end  if;  --  if  relation  statement 

end  EXPRESSION; 


--  RELATION  -->  SIMPLE_EXPRESSION  [SIMPLE_EXPRESSION_TAIL  ?] 
function  RELATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("RELATI0N"); 

end  if; 

if  (SIMPLE_EXPR£SSION)  then 

if  (SIMPLE_EXPReSSION_TAIL)  then 
null  ; 

end  if;  --  if  simpTe_e«pression_tail  statement 

return  (TRUE); 

else 

return  (FALSE); 

end  if;  --  if  simpTe_expression  statement 

end  RELATION; 


--  RELATIONTAIL  -->  [and  [then  ?]  RELATION]" 
-->  [or  [else  ?]  RELATION]" 
-->  [«or  RELATION]" 

function  RELATIONTAIL  return  boolean  is 
beg  in 

if  (P4. PRINT  CALLS)  then 
P4.0UT_PUT("RELAII0N_TAIL"); 
end  if; 

mhile  ( TM.MArCH( TM. TOKEN  AND) )  loop 
If  (TM.MATCH( TM. rOKENTMEN))  then 
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null; 
end  if; 

if  not  (RELATION)  then 

P4.SYNTAX_ERR0R( "Relation  tail"); 
end  if; 
end  loop; 

while  (TM.MATCH(TM.IOKEN_OR))  loop 
if  (TM.MATCH(TM.TOKEN_ELSE))  then 
null; 
end  if; 

if  not  (RELATION)  then 

P4 . SYNTAX_ERROR( "Relation  tail"); 
end  if; 
end  loop; 

while  (TM.MATCH(TM.TOKEN_XOR))  loop 
if  not  (RELATION)  then 

P4 . SYNTAX_ERROR( "Relation  tail"); 
end  if; 
end  loop; 
return  (TRUE); 
end  RELATION_TAIL; 


--  if  niatch(  toXen  then ) 


--  if  not  relation  statement 


--  if  iiiatch( toXen_e1  se ) 


--  if  not  relation  statement 


--  if  not  relation  statement 


--  SrMPLE_EXPRESSION  -->  [+  ?]  TERM  [BINARY_AODING_OPERATOR  TERM]* 
-->  [-  T]  TERM  [BINARY  AOOING_OPERATOfi  TERM]* 
function  SIMPLE_EXPRESSION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( "SIMPLE_EXPRESSION" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_PLUS)  or  TM .MAICH( TM. TOK£N_MINUS) )  then 
if  (TERM)  then 

while  (P4.BINARY_AOOING_OPERATOR)  loop 
if  not  (TERM)  then 

P4.SYNTAX_ERROR( "Simple  expression"); 
end  if;  --  if  not  term  statement 

end  loop; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple  expression"); 
end  if;  --  if  term  statement 

elsif  (TERM)  then 

while  (P4.BINARY_ADD1NG_0PERAT0R)  loop 
if  not  (TERM)  then 

P4 . SYNTAX_ERROR( "Simple  expression"); 
end  if;  --  if  not  term  statement 

end  loop; 
return  (TRUE); 
else 

return  (FALSE); 
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--  if  match( tol(en_p1  us )  et  al  statement 


end  if; 

end  SIMPLE_EXPRESSION; 


--  SIMPLE_EXPRESSION_TAIL  -->  RELATIONAL_OPERATOR  SIMPLE_EXPRESSION 

-->  [not  ?]  in  RANGES 
-->  [not  ?]  in  NAME 

function  SIMPLE_EXPRESSION_TAIL  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( •SIMPLE_EXPRESSION_TAIL“ ) ; 
end  if; 

if  (P4.RELATIONAL_OPERATOR)  then 
if  (SIMPLE_EXPRESSION)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simp! e  expression  tail"); 
end  if;  --  if  simple_express'ion  statement 

elsif  (rM.MArCH(TM.TOKEN_NOT))  then 
if  (TM.MATCH(TM.TOKEN_IN))  then 
if  (RANGES)  then 
return  (TRUE); 

elsif  (NAME)  then  --  check  for  type_mark 

return  (TRUE); 
el  se 

P4 . SYNTAX_ERROR( "Simple  expression  tail"); 
end  if;  --  if  ranges  statement 

else 

P4.SYNTAX_ERR0R("Simple  expression  tail"); 
end  if;  --  if  match(token_in)  statement 

elsif  (TM.MATCH(TM.TOKEN_IN))  then 
if  (RANGES)  then 
return  (TRUE); 

elsif  (NAME)  then  --  check  for  type_mark 

return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Simple  expression  tail"); 
end  if;  --  if  ranges  statement 

else 

return  (FALSE); 

end  if;  --  if  relational_operator  statement 

end  SIMPLE_EXPRESSION_TAIL; 


--  TERM  -->  FACTOR  [MULTIPLYING_OPERATOR  FACTOR]* 
function  TERM  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("TERM"); 
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end  if; 

if  (FACTOR)  then 

while  (P4.MULTIPLYING_OPERATOR)  loop 
if  not  (FACTOR)  then 
P4 .SYNTAX_ERROR( "Term" ) ; 
end  if; 
end  loop; 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 
end  TERM; 
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--  FACTOR  -->  PRIMARY  [••  PRIMARY  ?] 
abs  PRIMARY 
-->  not  PRIMARY 

function  FAClOH  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "FACTOR"); 
end  if; 

if  (PRIMARY)  then 

if  (TM.MATCH(TM.TOKEN_EXPONENT))  then 
if  (PRIMARY)  then 
null ; 
else 

P4.SYNTAX_ERR0R( "Factor" ) ; 
end  if; 
end  if; 

return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_ABSOLUTE))  then 
if  (PRIMARY)  then 
return  (TRUE); 
else 

P4,SYNTAX_ERROR("Factor" ); 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_NOT))  then 
if  (PRIMARY)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR( "Factor" ) ; 
end  if; 
else 

return  (FALSE); 
end  if; 
end  FACTOR; 


if  not  factor  statement 


if  factor  statement 


if  primary  statement 
if  match( toXen_exponent ) 


if  primary(abs) 


if  primary(not) 


if  primary  statement 


--  PRIMARY  --> 

--> 

--> 

--> 


numeric_l i teral 
null 

string_l iteral 
new  ALLOCATOR 
NAME 

AGGREGATE 


function  PRIMARY  return  boolean  is 


begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "PRIMARY"): 
end  if; 

if  (TM.MATCH(TM.TOKEM_NUMERIC_LI TERAL))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_NULL))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_STRING_LITERAL))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_NEW))  then 
if  (ALLOCATOR)  then 
return  (TRUE); 
else 

P4.SYNTAX_ERR0R( "Primary" ); 

end  if;  --  if  allocator  statement 

elsif  (NAME)  then 
return  (TRUE); 
elsif  (AGGREGATE)  then 
return  (TRUE); 
e  1  $e 

return  (FALSE); 

end  'f;  --  if  match( token_l ef t_paren ) 

end  PRIMARY; 


--  CONSTRAINT  --> 
--> 

--> 

--> 

function  CONSTRAINT 


range  RANGES 
range  <> 

digits  FLOATING_OR_FIXED_POINT_CONSTRAINT 
delta  FLOATING_OR_FIXEO_POINT_CONSTRAINT 
( INDEXCONSTRAINT 
return  boolean  is 


beg  i  n 

if  (P4.PRINT_CALLS)  then 
P4 .0UT_PUT( "CONSTRAINT" ) ; 
end  if; 

if  (TM.MATCH(TM.T0XEN_RANGE))  then 
if  (RANGES)  then 
return  (TRUE); 

elsif  ( TM.MATCH( IM . T0KEN_BRACKETS) )  then  --  check  for  <>  when  parsing 
return  (TRUE);  --  an  unconstrained  array 

e  I  se 


P4 . SYNTAX  ERROR! "Cons I ra  i n t " ) ; 
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end  if;  --  if  ranges  statement 

elsif  (TM.MATCH(rM.rOKEN_DIGITS))  or  else  ( TM.MATCH( TM . TOKEN_DELTA) )  then 
If  (FLOATING_Oft_FIXED_POINT_CONSTRAINI)  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Constraint" ) ; 
end  if; 

elsif  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
if  (INDEX_CONSTRAINT)  then 
return  (TRUE): 
else 

P4.SYNTAX_ERROR( "Constraint" ) ; 
end  if; 
else 

return  (FALSE); 
end  if; 

end  CONSTRAINT; 


--  FL0ATING_0R_FIXE0_P01NT_C0NSTRAINI  -->  SIMPLE_EXPRESSION  [range  RANGES  ?] 
function  FLOATlNG_OR_FIXED_POINT_CONSTRAINT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("fL0ATING_0R_FIX£D_P0INT_C0NSTRAINT*); 
end  if; 

If  (SIMPLE_EXPR£SS10N)  then 

if  (TM.MATCH(TM.TOI(£N_RANG£))  then 
If  (RANGES)  then 
null ; 
else 

P4 , SYNTAX_ERROR( " F loat ing  or  fixed  point  constraint"); 
end  if;  --  if  ranges  statement 

end  if;  --  if  match( toXenrange) 

return  (TRUE): 
else 

return  (FALSE); 

end  if;  --  if  simpleexpression  statement 

end  FLOATING_OR_FIXED_POINT_CONSTRAINT; 


--  INOEXCONSTRAINT  -->  OISCRETERANGE  [.  OISCRETERANGE]*  ) 
function  INDEXCONSTRAINT  return  boolean  is 
beg  1  n 

if  (PA.PRINTCALLS)  then 

P4 .0UT_PUT( "INDEXCONSTRAINT" ) ; 
end  I  f  ; 

if  (OISCRETE  RANGE )  then 
while  (TM.MATCH(TM. TOKEN  COMMA))  loop 
If  not  (UlSCRE It  RANGE  )  then 
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P4 , SYNTAX_ERROR{ "Index  constraint"  ) ; 
end  if; 
end  loop; 

if  (TM.MATCH(TM.TOKEN_RIGHT_PAREN))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Index  constraint”); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  INOEXCONSTRAINT; 


if  not  discrete_range 


if  iiiatch( token_right_paren ) 


if  discrete_range  statement 


--  RANGES  -->  SIMPLE_EXPRESSIOM  [ , . SIMPLE_EXPRESSION  ?] 
function  RANGES  return  boolean  is 


begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT( "RANGES"); 
end  if; 

if  (SIMPLE_EXPRESSION)  then 

if  (TM.MATCH(TM.TOKEN_RANGE_OOTS) )  then 
if  (SIMPLE_EXPRESSION)  then 
null ; 
else 

P4 .SYNTAX_ERROR( "Ranges" ) ; 

end  if;  --  if  simple_expression  statement 

end  if;  --  if  match( tolten_range_dots ) 

return  (TRUE); 
else 

return  (FALSE); 

end  if;  --  if  simpleexpression  statement 

end  RANGES; 


--  AGGREGATE  -->  (COMPONENTASSOCIATION  [.  COMPONENTASSOCIATION]*  ) 
function  AGGREGATE  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT  PUT( "AGGREGATE" ) ; 
end  i f ; 

if  ( rM.MATCH( TM. TOKEN_LEFT_PAREN) )  then 
if  (COMPONENT_ASSOCIATION)  then 
while  (TM.MATCH(rM.fOKEN_COMMA))  loop 
If  not  (COMPONENTASSOCIATION)  then 
P4  . SYNTAX_ERROR( "Aggregate" ) ; 

end  if;  --  if  not  component  association 

end  loop; 

if  ( TM.MAICH) IM. TOKEN  RIGHTPAREN ) )  then 
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return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Aggregate" ) ; 

end  if;  --  if  match{ token_right_paren ) 

else 

P4.SYNTAX_ERR0R( "Aggregate" ) ; 

end  if;  --  if  coniponent_association 

else 

return  (FALSE); 

end  if;  --  if  matcti( token_Ief t_paren) 

end  AGGREGATE; 


--  COMPONENTASSOCIATION  -->  [CHOICE  [[  CHOICE]*  =>  ?]  EXPRESSION 
function  COMPONENT_ASSOCI ATION  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT("C0MP0NENT_ASS0CIATI0N" ) ; 
end  if; 

if  (CHOICE)  then 

mhile  ( TM.MATCH( TM . TOKEN_BAR ) )  loop 
if  not  (CHOICE)  then 

P4 . SYNTAX_ERROR( "Component  asociation" ) ; 
end  If; 
end  loop; 

if  (TM.MATCH(TM.TOK£N_ARROW))  then 
if  (EXPRESSION)  then 
null; 
else 

P4 .SYNTAX_ERROR( "Component  asociation" ) ; 
end  if;  --  if  expression  statement 

end  if;  if  match( token_arroi») 

return  (TRUE); 
else 

return  (FALSE); 

end  if;  ■-  if  choice  statement 

end  COMPONENTASSOCIATION; 


--  ALLOCATOR  -->  SUBTYPE_INOICATION  ['AGGREGATE  ?] 
function  ALLOCATOR  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( "ALLOCATOR" ) ; 
end  if; 

if  (SUBTYPE  INDICATION)  then 

if  (TM.MATCH(TM.T0KEN_AP0STR0PHE))  then 
if  (AGGREGATE)  then 
null; 


else 

P4.SYNTAX_ERR0R( "Allocator" ) ; 
end  if; 
end  if; 

return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  ALLOCATOR; 


--  if  aggregate  statement 
--  if  match(tolcen_apostrophe) 


--  if  subtype_indication  statement 


--  NAME  -->  identifier  [NAME_TAIL  ?] 

-->  character_l iteral  [NAMETAIL  ?] 

-->  string_l iteral  [NAME_TAIL  ?] 
function  NAME  return  boolean  is 
SEARCii  POlNTER  ;  SYMBOL_TABLE  .  SYM_TAB_ACCESS; 

STARTTOKEN  ;  TOKEN_SCANNER . TOKEN_RECORD_TYPE ; 

L0CATI0N_0NE  ;  positive; 

LOCATIONTWO  ;  positive; 

use  SYMBOL_TABLE; 

begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("NAME"); 
end  if; 

if  (TM.MATCH(TM.TOKEN_IDENTIFIER))  then 
TM  ,  MATCHE0_T0KEN(  START_TOICEN ) ; 

SEARCH_POINTER  :• 

SYM80L_TABLE . FIND_KEY( START_TOKEN . LEX£ME( 1 . .START_TOKEN . LEXEME_SI ZE ) ) ; 
if  (NAME_TAIL)  then 
null; 

elsif  (TM.MATCH(TM. rOKEN_COLON))  then 

If  (CODE_BLOCXER.CURRENT_STATEMENT_COUNT  /=  0)  then 

LOCATION_ONE  ;=  COOE_BLOCKER.CURRENT_CODE_BLOCK_NUMBER; 

COOE_BLOCKER . EX  I T_COOE_8LOCK( START_TOKEN . SOURCE ) ; 

COOE_8LOCKER.ENTER_COOE_BLOCK(START_TOKEN. SOURCE,  "LABELLED  BLOCK" ) ; 
LOCATION_TWO  ;=  C00E_BL0CKER , CURRENT_CODE_BLOCK_NUMBER ; 
COOE_BLOCKER.INCREMENT_STAFEMENT_COUNT; 
NET_GENERATOR.CONNECT_BLOCKS(LOCATIOM_ONE.  LOCATIONTWO ) ; 
else 

C00E_BL0CKER,0ELETE_C00E_BL0CK  ENTER; 

COOE_BLOCKER,ENTER_COOE_BLOCK(START_TOKEN. SOURCE,  "LABELLED  BLOCK" ); 
COOEBLOCKER. INCREMENTSTATEMENTCOUNT; 

LOCATIONTWO  ;=  C00E_BL0CKER .CURRENT_COOE_BLOCK_NUMBER ; 
end  if; 

if  ( SYMBOL_TABLE.FIND_KEY( START  TOKEN. LEXEME(1. . 
STARTTOKEN.LEXEMESIZE) )  =  null)  then 
SYMBOL  TABL E. INSEfiT_SYMTAB( START  TOKEN. 

LEXEME( 1 . .START_TOKEN.LEXEME_SIZE) , 

SYMBOL  TABLE .LABEL  NAME ,  LOCAT ION  TWO ) ; 

e  I  se 
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SVMBOL_TABLE .UPDATE_SYM_TAB(LOCATION_TyO); 
end  if; 

return  (FALSE); 
end  if; 

return  (TRUE); 

elsif  (TM.MATCH(TM. TOKENCHARACTERLITERAL))  then 
if  (NAME_TAIL)  then 
null; 
end  if; 

return  (TRUE); 

elsif  (TM.MATCH(TM.T0KEN_STRING_UTERAL))  then 
if  (NAME_TAIL)  then 
null; 
end  if; 

return  (TRUE); 
else 

return  (FALSE); 
end  if; 
end  NAME ; 


--  NAM£_TAIL  --> 
--> 

--> 

function  NAME  TAIL 


(LEFT_PAREN_NAME_TAIL 
.SELECTOR  [NAME_TAIL]* 

'AGGREGATE  [NAME_TAIL]* 
•ATTRIBUTE_OESIGNATOR  [NAME_TAIL]* 
return  boolean  is 


begin 


if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT("NAME_TAIL" ) ; 
end  if; 


if  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
SYMBOL_TABLE.SAVE_CURRENTJNTRY; 
if  (LEFT_PAHEN_NAME_TArL)  then 
SYMBOLTABLE . RESTORE  CURRENTENTRY ; 
return  (TRUE); 
else 


SYMBOL_TABLE . RESTORE_CURR£NT_ENTRY ; 
return  (FALSE); 

end  if;  --  if  lefl_paren_name_tail 

elsif  (TM.MATCH(TM.TOKEN_PERIOO))  then 
if  (P4. SELECTOR)  then 
while  (NAME_TAIL)  loop 
nul  1  ; 
end  loop; 
return  ( TRUE  ) ; 
e  1  se 


P4  .  SYNIA,’(_ERROR(  "Name  tail  ;  enpecting  selector”); 
end  if;  --  if  selector  statement 

elsif  ( TM.MATCH( TM. TOKEN  APOSTROPHE ) )  then 
SYMBOL  TABIE  SAVE  CURRENT  ENTRY; 
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if  (AGGREGATE)  then 
while  (NAMETAIL)  loop 
null; 
end  loop; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
return  (TRUE); 

elsif  (ATTRIBUTE_OESIGNATOR)  then 
while  (NAME_TAIL)  loop 
null; 
end  loop; 

SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Name  tail  ;  expecting  aggregate  or  attribute"); 
end  if;  --  if  aggregate  statement 

else 

return  (FALSE); 

end  if;  --  if  match( tokenl ef tparen ) 

end  NAME_TA[L; 


--  LEFT_PAfiEN_NAME_TAIL  -->  [ FORMAL_PARAMETER  ?]  EXPRESSION  [..EXPRESSION  ?] 

[,  [FORMAL_PARAMETER  ?]  EXPRESSION  [..EXPRESSION  ?]]• 
)  [NAME_TAIL]» 

function  LEFT  PAREN  NAME  TAIL  return  boolean  is 


begin 

if  (P4.PRINT_CALLS)  then 

P4.0UT_PUT( "LEFT_PAREN_NAME_rAIL"); 
end  if; 

if  ( P4 . F0RMAL_PARAMETER )  then  --  check  for  optional  formal  parameter 


null;  --  before  the  actual  parameter 

end  if;  --  if  formal_parameter  statement 

if  (EXPRESSION)  then 

if  (TM.MATCH( TM, TOKEN_RANGE_DOTS) )  then 
if  not  (EXPRESSION)  then 

P4 . SYNTAX_ERROR( "Lef t  paren  name  tail"); 
end  if;  --  if  not  expression  statement 

end  if;  --  if  match( tokenrangedots ) 

while  (TM.MATCH(TM.TOKEN_COMMA))  loop 
if  (P4.fORMAL_PARAMETER)  then 
null; 


end  if;  --if  formalparameter  statement 

if  not  (EXPRESSION)  then 

P4 , SYNTAX_ERROR( "Lef t  paren  name  tail"); 
end  if;  -•  if  not  expression  statement 

If  ( rM.MATCH( TM. TOKEN  RANGEQOTS))  then 
if  not  (EXPRESSION)  then 
P4 . SYNTAX_ERROR( "Lef t  paren  name  tail"); 
end  if;  --  if  not  expression  statement 


end  1  f ; 


if  raatch(token  range  dots) 
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end  loop; 

if  (TM.MATCH(TM.IOKEN_RIGHT_PAREN))  then 
atlile  {NAME_TAR)  loop 
null; 
end  loop: 
return  (TRUE); 
else 

return  (FALSE); 

end  if;  --  if  match( token_right_paren ) 

elsif  (DISCRETE_RANGE)  then 

if  (TM.MATCH(TM. TOKEN_RIGHT_PAR£N))  then 
while  (NAMETAIL)  loop 
nul  1  ; 
end  loop; 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Lef t  paren  name  tail"); 
end  if; 
e  1  se 

return  (FALSE); 

end  if;  --  if  match( tokenrightparen ) 

end  LEFT_PAREN_NAME_TAIL; 


--  ATTRIBUT£_DESlGNATrR  -->  identifier  [(EXPRESSION)  ?] 

-->  range  [(EXPRESSION)  ?] 

-->  digits  [(EXPRESSION)  ?] 

-->  delta  [(EXPRESSION)  ?] 
function  ATTRIBUTE_0ESIGNATQR  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 
P4.0UT_PUT(  '■  ATTRIBUTE  _0ES10NAT0R"  ); 
end  if; 

if  (  rM.MATCH(TM.TOKEN_IOENriFIER))  or  else  ( TM . MATCH( TM . TOKEN_RANGE ) )  then 
if  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
If  (EXPRESSION)  then 

if  ( rM.MArCH( IM. TOKENRIGHI^PAREN))  then 
null; 
e  I  se 

P4,SYNTAX_ERR0R( “Attribute  designator"); 
end  if;  --  if  roalch( tokenrightparen ) 

else 

P4.SYNTAX_ERR0R( "Attribute  designator”); 
end  if:  -  if  expression  statement 

end  if;  --  if  match( tokenl if tparen ) 

return  (TRUE); 

elsif  ( TM.MATCH( TM, TOKENOIGl TS) )  or  else  ( IM . MA rCM( IM , lOKENDE L TA  ) )  then 
It  ( TM.MATCH( TM. lOKENLEF I  PAREN) )  then 
if  (EXPRESSION)  then 

if  (  IM.MAICHI  TM.  lOklN  l<  I  GH  I  PARE  N  ) )  then 
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null  ; 
else 

P4 . SYNTAX_£RROR( "Attribute  designator”); 
end  if;  --  if  match( tok.en_r ight  paren ) 

e  1  se 

P4 . SYNTAX_ERROR( "Attribute  designator"); 
end  if;  --  if  expression  statement 

end  if;  --  if  match( tolten_left_paren ) 

return  (TRUE); 
else 

return  (FALSE); 

end  if;  --  if  inatch( tolcen_ident if ier) 

end  ATTRIBUTEDESIGNATOR; 


--  INTEGER_TYPE_OEFINITION  -->  range  RANGES 
function  INTEGER_TYPE_OEF iMIT'ON  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .0UT_PUT( "INTEGER_TYPE_DEFINITION" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_RANGE))  then 
if  (RANGES)  then 
return  (TRUE); 
else 

P4 . SYNTAX_£RROR( ” Integer  type  definition”); 
end  if; 
else 

return  (FALSE); 
end  if; 

end  INTEGER_TYPE_DEFINIT10N; 


--  DISCRETERANGE  -->  RANGES  [CONSTRAINT  ?] 
function  OISCRETE_RANGE  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "DISCRETERANGE" ) ; 

end  if; 

if  (RANGES)  then 

if  (CONSTRAINT)  then 
null  ; 

end  if;  --  if  constraint  statement 

return  ( TRUE  ) ; 

e  1  se 

return  (FALSE); 

end  if;  -  if  ranges  statement 

end  DISCRE  IE  RANGE  ; 
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--  EXIT_STATEMENT  -->  [NAME  ?]  [when  EXPRESSION  ?]  ; 
function  EXIT_STATEMENT  return  boolean  is 
begin 

If  (P4.PRINT_CALLS)  then 
P4.0UT_PUT(”EXIT_SrArEMENr“ ); 
end  if; 

if  (NAME)  then 
null: 

end  if;  --  if  name  statement 

if  (TM.MATCH(TM.rOXEN_WHEN))  then 
if  (EXPRESSION)  then 
null; 
el  se 

P4 . SYNTAX_ERROfi( "Exit  statement" ) ; 
end  if;  --  if  expression  statement 

end  if;  --  if  match( token  when ) 

if  ( TM.MATCH( TM. T0KEN_SEM[C0L0N) )  then 
return  (TRUE); 
else 

return  (FALSE); 

end  if;  --  if  match( token_semicolon ) 

end  EXIT_STATEMENT; 


--  RETURN_STATEMENT  --)  [EXPRESSION  ?]  ; 
function  R£TURN_STATEMENT  return  boolean  is 
begin 

if  (P4.PRINr_CALLS)  then 

P4 .OUT_PUT( "RETURN_STATEMENT" ) ; 
end  if; 

if  (EXPRESSION)  then 
null  ; 
end  if; 

if  (TM.MATCH(TM.TOXEN_SEMICOLON))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  RETURN_STATEMENr; 


--  GOTO_STATEMENT  -->  NAME  ; 
function  GOTOSTATEMENT  return  boolean  is 
STARTTOXEN  :  TOKEN_SCANNER . TOXENRECORDIYPE ; 
LOCATION  ONE  :  positive; 
use  SYMBOL  TABLE: 
begin 
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if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( "GOTO_STATEMENT” ) ; 
end  if; 

if  (NAME)  then 

TM . MATCHEO_TOKEN( START  TOKEN ) ; 

i f  ( SYMBOL_TABLE . F IND_KEY( STARTTOKEN . LEXEME ( 1 . . STARTTOKEN . LEXEME_SI ZE ) ) 

=  null)  then 

SYMBOL_TABLE . INSERT_SYM_TAB(START_TOKEN.LEXEME( 1 . . START_TOKEN . 

LEXEME_SIZE ) , SYMBOL_TABLE . LABEL_NAME .  0 ) : 
end  if; 

LOCATION_ONE  :=  COOE_BLOCKER.CURRENT_COOE_BLOCK_NUMBER; 

NET_GENERATOR.GO_TO( LOCATION  ONE. 

SYMBOLTABLE . F INO_KEY( START_TOKEN . LEXEME( 1 . . START_TOKEM , LEXEMESIZE ) ) ) ; 
CODE_BLOCKER.INCREMENT_STATEMENT_COUMT; 

CODE_BLOCKER . EXI T_COOE_BLOCK( START_TOKEN . SOURCE ) ; 

CODE_BLOCKER . ENTER_COOE_BLOCK( STARTTOKEN . SOURCE ,  " " ) ; 
if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4.SYNTAX_ERROR( "Goto  statement"); 

end  if;  --  if  match( token_semicol on ) 

else 

return  (FALSE); 

end  if;  --  if  name  statement 

end  GOTO_STATEMENT; 


--  OELAYSTATEMENT  -->  SlMPL£_EXPR£SSlON  ; 
function  DELAY_STATEM£NT  return  boolean  is 
beg  i  n 

if  (P4.PRINT_CALLS)  then 
P4 .OUT_PUT( "OELAY_STATEMENT" ) ; 
end  if; 

if  (SIMPLE_EXPRESSION)  then 

if  (TM.MATCH(TM, TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Delay  statement" ) ; 

match( token_semicolon ) 


simpleexpression  statement 

end  OELAYSTATEMENT ; 


end  if;  -  -  if 

else 

return  (FALSE); 

end  if;  --  if 


--  ABORTSTATEMENl  -->  NAME  [,  NAME]*  ; 
function  ABORTSTATEMEN T  return  boolean  is 
beg  i  n 

if  (P4.PRINr_CALLS)  then 
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P4.0UT_PUT( "A80RT_STATEM£NT" ) ; 
end  if; 

if  (NAME)  then 

while  (TM.MATCH(TM.TOKEN_COMMA))  loop 
if  not  (NAME)  then 
P4 .SYNTAX_ERROR( "Abort  statement" ) ; 
end  if; 
end  loop; 

if  (TM.MATCH(TM.TOKEN_SEMICOLON))  then 
return  (TRUE); 
else 

P4 . SYNTAX_ERROR( "Abort  statement’ ) ; 
end  if; 
else 

return  (FALSE); 
end  if; 

end  ABORT_STATEMENT; 


--  RAISE_STATEMENT  [NAME  ?]  ; 

function  RAISE_STATEMENT  return  boolean  is 
begin 

if  (P4.PRINT_CALLS)  then 

P4 .OUT_PUT( *RAISE_STAT£MENr" ) ; 
end  if; 

if  (NAME)  then 
null ; 
end  if; 

if  (TM.MATCH(TM.roXEN_S£MICOLON))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  RAISE_STATEMENT; 
end  PARSER_3; 


if  not  name  statement 


if  inatch( toXen_semicol on ) 


if  name  statement 
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TITLE: 


ADAFLOW 


--  MODULE  NAME:  PACKAGE  PARSER_4 

--  FILE  NAME:  PARSER4.ADS 

--  DATE  CREATED:  20  FEB  88 

--  LAST  MODIFIED:  28  APR  88 

--  AUTHOR(S):  LT  ALBERT  J.  GRECCO,  DSN 

--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY: 

LCDR  JEFFREY  L.  NIEDER,  USN 
LT  KARL  S.  FAIRBANKS.  JR..  USN 
LCDR  PAUL  M.  HERZIG.  USN 

--  DESCRIPTION:  This  package  defines  the  functions  that 
are  the  lowest  level  productions  for  a  top-down, 
recursive  descent  parser. 


with  TEKT_IO.  TOKEM_MATCHEH: 
package  PARSER_4  is 

PRINr_CALLS  ;  boolean  FALSE; 

PARSER_£RROR  :  exception; 

function  MULriPLYING_OPERATOR  return  boolean; 
function  BINARY_AODING_OPERATOR  return  boolean; 
function  RELATIONAL_OPERATOR  return  boolean; 
function  ENUMERATI0N_TYPE_0EFINIT10N  return  boolean; 
function  ENUMERATION_LITERAL  return  boolean; 
function  FORMAL_PARAMETER  return  boolean; 
function  SELECTOR  return  boolean; 

procedure  SYNTAK_ERROR( ERROR_MtSSAGE  :  in  string); 

procedure  OUT_PUT( FUNCTIONNAME  :  in  string); 


end  PARSER_4; 


TITLE: 


ADA FLOW 


MODULE  NAME; 
FILE  NAME: 

DATE  CREATED: 
LAST  MODIFIED: 


PACKAGE  PARSER_4 
PARSER4.AOB 

20  FEB  88 
28  APR  88 


--  AUTHOR(S):  LT  ALBERT  J.  GRECCO.  USM 


--  BASED  ON  A  MODIFIED  ADA  GRAMMAR  DEVELOPED  BY: 

LCDR  JEFFREY  L.  NIEDER,  USM 
LT  KARL  S.  FAIRBANKS,  JR..  USN 
LCDR  PAUL  M.  HERZIG,  USN 

DESCRIPTION:  This  package  implements  functions  that 
are  the  lowest  level  productions  for  a  top-down, 
recursive  descent  parser.  Each  function  is  preceded 
by  the  grammar  productions  they  are  implementing. 


with  TOKEN_MATCH£R,  TOKEN_SCANNER.  TEXT_IO.  SYMBOL_TABLE ; 

package  body  PARSER_4  is 

package  TM  renames  TOK£N_MATCHER ; 

--  MULTIPLYING_OPERATOR  -->  • 

-->  / 

-->  mod 
-->  rem 

function  MULTIPLYING_0PERAT0R  return  boolean  is 
begin 

if  (PRINTCALLS)  then 
0UT_PUT( "MULTIPLYING_OPERArOR” ): 
end  if; 

if  (TM.MATCH(TM.TOKEN_ASTERISK))  then 
return  (TRUE); 

e1sif  (TM.MATCH(TM.TOKEN_SLASH))  then 
return  (TRUE); 

elsif  (TM,MATCH(rM.IOKEN_MOO))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_REM))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  MUt TIPLYING  OPERATOR; 
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--  binary_adding_operator  -->  ♦ 

->  - 

& 

function  BINARYADDINGOPERATOR  return  boolean  is 
begin 

if  (PRIMTCALLS)  then 
OUT_PUT( "BINARY_A00ING_0PERA:0R" ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_PLUS))  then 
return  (TRUE): 

elsif  (TM.MATCH(TM.TOK£N_MINUS))  than 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN_AMPERSANO))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  BINARY_ADOING_OPERATOR; 


--  fl£LATIOMAL_OPERATOR  -->  = 

/  = 

-->  < 

<  = 

-->  > 

-->  >  = 

function  RELATI0NAL_0PERAT0R  return  boolean  is 
begin 

if  (PRINT_CALLS)  then 
OUT_PUT( "RELATrONALOPERATOR” ) ; 

end  if; 

if  (TM.Ii«ATCH(TM.TOKEN_E0UALS))  then 
return  (TRUE); 

elsif  (TM.HATCH(TM.TOKEN_NOT_EQUALS))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.T0ICEN_LESS_THAN))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.TOlCEN_L£SS_THAN_EQUALS))  then 
return  (TRUE); 

elsif  (TM.MATCH( TM. TOKEN_GREArER_rHAN) )  then 
return  (TRUE); 

elsif  (TM.MATCH( TM. TOKEN_GREATER_rHAN_EOUALS) )  then 
return  (TRUE); 

else 

return  (FALSE); 

end  if; 

end  REl AT lONAl  OPERATOR ; 
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--  ENUMEflATION_TYPE_DEFINITION  -->  ( ENUMERAnON_LITERAL 

[,  ENUKIERATION_LnERAL]») 

function  ENUMERATI0N_TYPE_DEFINITI0N  return  boolean  is 
begin 

if  (PRINT_CALLS)  then 
OUT_PUT( "ENUMERATION_TYPE_OEFINI TI0N“ ) ; 
end  if; 

if  (TM.MATCH(TM.TOKEN_LEFT_PAREN))  then 
if  (ENUMERATION^LITERAL)  then 
while  (TM.MATCH(TM.TOKEN_COMMA))  loop 
if  not  (ENUMERATtONLITERAL)  then 

SYNTAX_ERROR( "Enumerat ion  type  definition"); 
end  if;  --  if  not  enuiiieration_l  iteral 

end  loop; 

if  (TM.MATCH(TM.TOKEN_RIGHT_PAREN))  then 
return  (TRUE); 
else 

SYNTAX_ERROR(  "Enunierat  ion  type  definition"); 
end  if;  --  if  niatcn(  token_right_paren ) 

else 

SYNTAX_ERROR( "Enumeration  type  definition"); 
end  if;  --  if  enumeration_1 i teral  statement 

else 

return  (FALSE); 

end  if;  --  if  match( toX6n_l ef t_par8n ) 

end  ENUM£RAriON_TYPE_DEFINITrON; 


--  ENUMERATION_LITERAL  -->  identifier 

-->  character_l iteral 
function  ENUMERATION_LI TERAL  return  boolean  is 
begin 

if  (PRINTCAllS)  then 
OUT_PUT( ”EMUMERATION_LI TERAL" ) ; 
end  if; 

if  (TM.MATCH(TM.TOXEN_IOENTIFIER))  then 
return  (TRUE); 

elsif  (TM. MATCH(TM. TOKEN  CHARACTERLITERAL))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 

end  ENUMERATION_LntRAL  ; 


--  FORMAI  PARAMETER  identifier  => 

function  formal  PARAMETER  return  boolean  is 


PEEK_AHEAO_TOKEN  :  TOKEN_SCANNER . TOKEN_RECORO_TYPE ; 

TESTTOKEN  :  TOKEN_SCANNER. TOKEN_RECORO_TYPE; 

use  TOKEN_SCANNER; 

begin 

if  (PRINTCALLS)  then 
OUT_PUT( "FORMAL_PARAMETER" ) ; 
end  if; 

TESTTOKEN. LEXEME  ;=  (others  =>  '  ’); 

TEST_T0KEN.LEXEME(1..2)  := 

TEST_TOKEN.LEXEME_SIZE  :=  2; 

TEST_TOKEN.TOKEN_TYPE  :=  TOKEN_SCANNER. DELIMITER; 
TM.MEXT_TOKEN(PEEK_AHEAO_TOKEN); 
if  (PEEK_AHEAO_TOKEN  =  TESTTOKEN)  then 
if  (TM.MATCH(TM.TOKEN_IOENTIfIER))  then 
if  (TM.MATCH(TM.TOKEN_ARROW))  then 
return  (TRUE); 
else 

SYNTAX_ERROR( "formal  parameter" ) ; 
end  if;  --  if  match(  tolcen_arro«() 

else 

SYNTAX_ERROR( "Forma  1  parameter" ) ; 

end  if;  --  if  match( token_ident i f ier ) 

else 

return  (FALSE); 
end  if; 

end  FORMAL_PARAMETER; 


--  SELECTOR  identifier 

-->  character_l i teral 
-->  string_l iterat 
-->  all 

function  SELECTOR  return  boolean  is 
SEARCHPOINTER  :  SYMBOL_TABLE . SYMTABACCESS; 

SEARCH_TOKEN  :  TOKENSCANNER , TOKEN_RECORD_TYPE ; 

use  SYMBOL_TABLE; 

begin 

if  (PRINTCALLS)  then 
OUT_PUT( "SELECTOR"); 
end  if; 

if  (TM.MATCH(TM.TOKENJOENTIFIEfl))  then 
TM . MATCHED_TOKEN( SE ARCHTOKEN ) ; 

SEARCHPOINTER  ;=  SYMBOL_TABLE . RETRIEVESYM; 
if  (SEARCH_POINTER  /=  null)  then 
SEARCHPOINTER  :=  SYMBOL_TABLE . SELECT_COMPONENI( SE ARCHTCKEN . 

LEXEME( 1. .SEARCHTOKEN.LEXEMESIZE)) ; 

end  if; 

return  (TRUE); 

elsif  (TM.MATCH(TM.TOKEN  CHARACTER  LITERAL))  then 
return  ( TRUE ) ; 


elsif  (TM.MATCH(TM.TOKEN_STRING_LITERAL))  then 
return  (TRUE); 

elsif  (TM.MATCH(TM.T0KEN_ALL))  then 
return  (TRUE); 
else 

return  (FALSE); 
end  if; 
end  SELECTOR; 

procedure  SYNTAX_ERROR( ERROR_MESSAGE  :  In  string)  is 
begin 

TEXT_IO. new_l ine( 2 ) ; 

TEXT_IO. put( "Incomplete  "); 

TEXTIO. put( ERROR_MESSAGE ) ; 

TEXT_IO.put( "  at  line  number  "); 

TEXT_IO.put(positiwe' IMAGE(TM.LINES_CHECKE0)); 

TEXT_IO.  ne«(_1  ine(  2 ) ; 
raise  PARSERERROR; 
end  SYNTAXERROR; 

procedure  OUT_PUT( FUNCTIONJIAME  ;  in  string)  is 
TOPTOKEN  ;  TOXEN_SCANNER . TOKEN_RECORO_TYPE ; 
use  TEXT_IO,  TOKEN_SCANNER; 
begin 

TOKEN_MATCHER.CURRENT_TOKEN(TOP_TOKEN); 
put(FUNCTION_NAME);  set_COl(40); 
if  (T0P_T0KEN.T0KEN_TYPE  /=  TOKEN_SCANNER.£OF)  then 
for  LEXEME_INOEX  in  1 . . T0P_T0KEN . LEXEME_SIZE  loop 
put(TOP_TOIiEN.LEXEME(LEXEME_INDEX)); 
end  loop; 
end  if; 

new_line;  set_co1(40); 

put_l i ne( TOKEN_SCANNER . TOKEN_CLASS ' IMAGE( TOP  TOKEN . TOKEN  TYPE  ) ) ; 
end  OUTPUT; 

end  PARSER_4; 
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APPENDIX  D 


”ADAFL.OW”  PROGRAM  LISTING  -  NETGENERATOK 


TITLE; 

ADAFLOW 

-- 

MODULE  NAME: 

PACKAGE  NETGENERATOR 

file  NAME: 

NET. AOS 

DATE  CREATED; 

12  MAR  88 

LAST  MODIFIED 

28  APR  88 

AUTHOR(S)  : 

LI  ALBERT  J.  GRECCO.  USN 

-- 

DESCRIPTION: 

This  package  contains  the  procedures  which 
define  the  interface  to  the  net  generator. 

-- 

with  SYMBOL_TABLE; 
package  NEr_GENERATOfl  is 

NET_GENERATOR_QV£RFLOW  ;  exception; 

procedure  START( RUN_UN1 T_NAME  :  in  SYMBOL_TABLE .SYM_TAB_ACCESS) ; 

--  post  -  Defines  a  either  a  subprogram  place  or  task  place  that  has 
an  initial  marking  in  the  petri  net  model. 

procedure  OECISION_START(START_PLACE  ;  in  positive; 

ENOPLACE  ;  in  SYMEOLTABLE , SYM_TAB_ACCESS) ; 

--  post  -  Defines  a  place  that  is  the  root  place  of  a  multi-way  decision 
path  and  it's  corresponding  end  label. 

procedure  DECISION_DR( ENDPATHPLACE  :  in  positive); 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  starts  the 
next  path.  The  decision  start  place  is  reactivated  as  the 
current  block  number. 

procedure  EXPLICn_DEClS10N_DR; 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  starts  the 
next  path.  The  decision  start  place  is  reactivated  as  the 
current  block  number. 
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procedure  ENO_DECISION(END_PATH_PLACE  :  in  positive); 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  terminates 
the  multi-way  decision. 

procedure  EXPLICIT_ENO_DECISIQN; 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  terminates 
the  multi-way  decision. 

procedure  CALL(CURRENT_LOCATION  :  in  positive: 

PROCEOURE_LOCATION  :  in  SYMBOL_TABLE .StM_TAB_ACCESS) ; 

--  pre  -  The  procedure  location  must  be  the  current  entry  in  the 
symbol  table. 

--  post  -  The  abstract  grammar  for  a  procedure  call  is  generated. 

procedure  ENTRY_CALL(CURRENT_LOCATION  :  in  positive; 

ENTRYLOCATION  :  in  SYMBOL_TABLE .SYM_TAB_ACCESS) ; 
--  pre  -  The  entry  location  must  be  the  current  entry  in  the 
symbol  table. 

'-  post  -  The  abstract  grammar  for  a  task  entry  is  generated. 

procedure  TASK_ACCEPT(CURRENr_LOCATION  :  in  positive: 

ENTRY_LOCATION  :  in  positive); 

--  post  -  The  abstract  grammar  for  a  task  accept  is  generated. 

procedure  £ND_ACCEPT(CURRENT_LOCATION  ;  in  positive; 

ENTRYENO  ;  in  positive); 

--  post  -  The  abstract  grammar  for  the  end  of  an  accept  statement  is 
generated. 

procedure  EXPLICI T_ENO_ACCEPT( ENTRY_ENO  :  in  positive): 

--  post  -  The  abstract  grammar  for  the  end  of  an  accept  statement  is 
generated. 

procedure  GO_TO(CURRENT_LOCATION  :  in  positive; 

GO_TO_LOCATION  :  in  SYM80L_TABLE .SYM_TAB_ACCESS) ; 

--  post  -  The  abstract  grammar  for  a  goto  statement  is  generated. 

procedure  END_LOOP( ENOLOCATION  ;  in  positive; 

LOOP_STARr  ;  in  SYM80L_TABLE . SYM_TAB_ACCESS ) ; 

-  post  -  The  abstract  grammar  for  a  loop  is  generated. 

procedure  CONNECT_BLOCKS(CURRENT_lOCAT10N  :  in  positive; 

NEXTLOCATION  :  in  positive); 

--  post  -  used  to  enplicitly  declare  a  transition  between  two  known 

code  blocks.  The  abstract  grammar  for  a  transition  between 
two  petri  net  places  is  generated. 

procedure  EXPLIC I T_END( NEXTLOCAT ION  :  in  positive); 

--  post  -  The  current  forest  is  terminated  and  a  new  forest  is  begun. 
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procedure  TRANSLATE_TO_PEANUT ; 

--  post  -  used  to  translate  the  abstract  petri  net  grammar  to  a 

text  file  used  as  an  input  file  to  P-MUT  petri  net  analyzer. 
Produces  two  files:  1)  a. out  -  P-MUT  input  file 

2)  place.dat  -  text  file  that  describes  all 
the  places  that  exist  in  the 
petri  net  and/or  the 
places  relation  to  the 
original  source  code. 

The  net  generator  and  code  blocker  are  reset  to  their 
initial  states. 

procedure  RESET_NET_GENERATOR; 

--  post  -  The  net  generator  is  returned  to  it's  initial  state, 
end  NETGENERATOR; 
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TITLE; 

ADAFLOW 

MODULE  NAME; 

PACKAGE  N£T_GENERAIOR 

FILE  NAME: 

NET.ADB 

DATE  CREATED; 

12  MAR  88 

LAST  MODIFIED; 

28  APR  88 

AUTHOR(S) ; 

LT  ALBERT  J.  GRtCCO.  USH 

DESCRIPTION: 

This  package  contains  the  1 

implement  the  interface  to  the  net  generator. 


with  TOKEN_SCANNEf!. 

G£M£RIC_LlSf  , 

G£NERIC_STACK, 

UNCHeC((E0_0EALL0CA  f  ION . 

SYIABOL_TA0L£. 

COD£_eLOCK£ft, 

TEXT_IO, 

tO_EXC£PTlOMS; 

package  body  N£T_GEN£ftArOR  is 

0UMMY_S0URCE  :  IOX£N_SCANNE R . SOURC£_R£CORO ; 

type  PETRI  _IO£NriFIER_ri'pe  is  (PLACE.  TRANSl T ION T ; 

type  LISTNODE  is 
record 

PETRI  TAG  ;  PE TR I _ lOENT I E I ER  TYPE  ; 

SYMBOL  :  SYMBOL _TA8LE . SYM_TAB_ACCESS  :=  null; 
end  record; 


type  LISTNOOEPOINTER  is  access  LIST_NOOE; 

package  NEST  STACK  is  new  GtNERlC_STACK(LIST_NO0E  POINTER) . 
NS  :  NEST_STACK. STACK; 

rRANSITI0N_P01NTER  :  L I  ST  NODE  POINTER ; 

DECISIONROOT  :  LIST  NODE  POINTER  null; 

OECtSIONTAlL  :  L 1 ST_NOD£_POI NTER  ;=  null; 

package  ABSTRAC I  _ SYN I  AX  L I S I  is 

type  1  1ST  instance  15  private; 
type  I  rsT  IS  access  1  1 jl  INSIANCI  , 


157 


LISTOVERFLOW  ;  exception; 

LISTUNOERFLOW  :  exception; 

Operations:  If  the  list  is  not  empty,  then  one  of  the  nodes  is  designated 

as  the  current  node.  Ocaasional 1y .  in  the  postcondition,  it  is  necessary 
to  refer  to  the  list  of  the  current  node  as  they  were  immediately  before 
execution  of  the  operation.  L-pre  and  c-pre,  respectively,  are  employed 
for  these  references. 

procedure  FIND_fIRST(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  first  node  is  the  current  node. 

exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty. 

procedure  FIND_NEXT(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
--  post  -  c-next  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

-  LISTOVERFLOW  if  the  last  node  is  the  current  node. 

procedure  FIND_PREVIOUS{ L  :  in  out  LIST); 

pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  LIST_UNOERFLOW  if  L  is  empty  or  c  is  the  first  node. 

procedure  FINO_LAST(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

-■  exceptions  raised  -  LlST_UNDERfLOW  if  L  is  empty. 

procedure  RETRIEVE(L  ;  in  LIST;  ITEM  :  out  LIST_N0DE_P01NTER) ; 

--  pre  -  The  list  L  is  not  empty, 

-•  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

procedure  UPDATE(L  :  in  out  LIST;  ITEM  :  in  L 1 ST_NOD£_POI NTER ) ; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  current  node  in  L  contains  ITEM  as  its  element. 

-  exceptions  raised  ■  L I STUNOERFLOW  if  L  is  empty. 

procedure  INSERT(L  :  in  out  LIST;  ITEM  :  in  L 1 STNODEPOINTE R ) ; 

-  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

-  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 

node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 

ITEM  is  the  current  node. 

--  exceptions  raised  -  LIST  OVERFLOW  if  L  has  reached  its  bound. 

procedure  0ELETE(L  :  in  out  LIST); 

pre  The  list  L  is  not  empty. 

post  -  t  pre  in  not  in  the  list  1.  If  tpre  was  the  first  node. 
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then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERfLOW  if  L  is  empty. 

function  SIZE_0F(L  ;  in  LIST)  return  natural; 

--  post  -  SIZE_0f  is  the  number  of  nodes  in  list  L. 

function  EMPTY(L  :  in  LIST)  return  boolean; 

--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 

function  FULL(L  :  in  LIST)  return  boolean; 

--  post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

function  FIRST(L  ;  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  first  node  is  the  current  node  in  L  then  FIRST  is  true,  else 
FIRST  is  false. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

function  LAST(L  :  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LAST  is  false. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

procedure  CREAT£(L  :  in  out  LIST;  SUCCESS  :  out  boolean); 

--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

procedure  0ISP0SE(L  ;  in  out  LIST); 

--  post  -  L-pre  does  not  exist. 

private 

type  NODE ; 

type  NODEPOINTER  is  access  NODE; 
type  NODE  is 
record 

ELEMENT  ;  L I STNODE^POI NTER ; 

NEXT  ;  NOOEPOINIER; 
end  record; 


type  LISTINSTANCE  is 


record 

HEAD 

NOOEPOINTER 

;  =  null 

TAIL 

NOOEPOINTER 

:  =  null 

CURRENT 

NODE  POINTER 

null 

SIZE 

natural  :=  0; 

end  record; 


159 


r 


V 


1 


i 


end  ABSTRACTSYNTAXLIST; 

package  FORESTLIST  is  new  GENERIC_LISi( ABSTRACT_SyNTAX_LIST . LIST) ; 
FOREST  :  FORESTLIST . LIST ; 


START_SYNTAX  :  ABSTRACT_SYNTAX_L I  ST . LI  ST ; 
STOP_PLACES  ;  ABSTRACTSYNTAXLIST . LIST ; 


package  body  ABSTRACTSYNTAXLIST  IS 


procedure  FREE  NODE  is  new  UNCHECKE0_0£ALLOCATI0N(N0DE ,  NODE_bOINTER)  ; 
procedure  FREE_LIST  is  new  UNCHECKED_OEALLOCATION(LIST_INSTANCE,  LIST); 
procedure  FREESYMRFC  is  new  UNCHECK£0_0EALL0CATI0N( SYMBOL_TABLE . 

SYM_TAB_R£CORD, 
SYMBOL_TABL£ . 
SYM_TAB_ACCESS); 


procedure  FINO_FIRST(L  :  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  first  node  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty, 
begin 

if  (EMPTy(L))  then 
raise  LIST_UND£RFLOU: 

end  if; 

L  CURRENT  :=  L.HEAD; 
end  fINO_FIRST; 


procedure  FIND_N£XT(L  :  in  out  LIST)  is 

--  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
--  post  -  c-next  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

-  LIST_OVERFLOW  if  the  last  node  is  the  current  node. 

begin 

if  (EMPTY(L))  then 
raise  LISTUNDERFLOW; 
end  if; 

if  (LAST(L))  then 
raise  LISTOVERFLOW; 
end  if; 

L. CURRENT  ;=  L . CURREN I . NE X I ; 
end  FIND_NEXT; 

procedure  F INO_PREVIOUS( L  ;  in  out  LIST)  is 

pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

-  exceptions  raised  -  LIST  UNDERFLOW  if  L  is  empty  or  c  is  the  first  node. 

TEMPPOINTER  ;  NOOEPOINTER ; 
beg  in 

If  (LMPlYd  )  or  f  1RS1(1  ))  then 
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raise  LISTUNOERFLOW; 
end  i f ; 

TEMP_POINTER  :=  L.HEAD: 

•hile  (TEMP_POINTER.NEXF  /=  L, CURRENT)  loop 
TEMPPOINTER  :=  TEMP_POINTER . NEXT ; 
end  loop: 

L. CURRENT  :=  TEMPPOINTER; 
end  FINOPREVIOUS; 

procedure  FINO_LAST(L  :  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  LlST_UNDEfiFLOW  if  L  is  empty, 
begin 

if  (EMPTY(L))  than 
raise  LISTUNOERFLOW; 
end  if; 

■hile  (not  LAST(L))  loop 
FINO_NEXT(L); 
end  loop; 
end  FIND_LAST; 

procedure  RETRI£VE(L  :  in  LIST;  ITEM  ;  out  LIST_NOOE_POINTER)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LIST_UN0ERFL0W  if  L  is  empty, 
begin 

If  (EMPTY(L))  then 
raise  LIST_UN0£RFL0W; 
end  if; 

ITEM  :=  L. CURRENT. ELEMENT; 
end  RETRIEVE; 

procedure  UPOATE(L  ;  in  out  LIST;  ITEM  ;  in  LIST_NOOE_POINTER)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  current  node  in  L  contains  ITEM  as  its  element. 

--  exceptions  raised  -  LISTUNOERF LOW  if  L  is  empty, 
beg  i  n 

if  (EMPTY(L))  then 
raise  LISTUNOERFLOW; 
end  if; 

L .CURRENT. ELEMENT  ;=  ITEM; 
end  UPDATE: 

procedure  INS£RT(L  :  in  out  LIST;  ITEM  ;  in  LIST_NODE_POINTER )  is 

--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 

node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 

ITEM  is  the  current  node. 

-  exceptions  raised  -  LIST  OVFRFIOW  if  L  has  reached  its  bound. 

TEMP  POINTER  :  NODE _P0I N I E R ; 
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use  SYMBOL^TABLE; 
begin 

if  (FULL(L))  then 
raise  LISTOVERELOW; 
end  if; 

TEMPPOINTER  :=  new  NODE '( ITEM ,  null); 

TEMP_POINTER . ELEMENT . SYMBOL . REFERENCE_COUNT  ; = 

natural ' SUCC{ TEMP_POIMTER . ELEMENT . SYMBOL . R£F£R£NCE_COUNT ) ; 
if  (L.HEAD  =  null)  then 
L.HEAO  :=  TEMP_POINTEfl; 

L.TAIL  :=  TEMP_POINTER: 
else 

L.TAIL. NEXT  :=  TEHP_POINTER ; 

L.TAIL  :=  TEMP_POINTER; 

end  if; 

L. CURRENT  ;=  TEMP_POINTER; 

L.SIZE  ;=  L.SI2E  +  1  ; 
end  INSERT; 

procedure  0£L£TE(L  :  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node. 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LIST_UNOERFLOW  if  L  is  empty. 

TEMP_POINTER  ;  NOOE_POINTER; 

use  SYMBOL_TABL£ ; 

begin 

If  (EMPTY(L))  then 
raise  LIST_UNOERFLOW; 
end  if; 

if  (L. CURRENT  /=  L.HEAD)  then 
TEMP_POINTER  :=  L.HEAO; 

while  (TEMP_POINTER.NEXT  /=  L. CURRENT)  loop 
TEMPPOINTER  ;=  TEMP_POINTER . NEXT; 
end  loop; 

TEMP_POINTER,NEXT  :  ==  L  . CURRENT . NEX T  ; 
if  (L. CURRENT  =  L.TAIL)  then 
L.TAIL  ;=  TEMP_POINTER; 
end  if; 
else 

if  (L.HEAD  =  L.TAIL)  then 
L.TAIL  :=  null; 
end  if; 

L.HEAD  :=  L.HEAD. NEXT; 
end  if; 

if  (L  CURRENT. ELEMENT. SYMBOL. REFERENCE_COUNT  >  1)  then 
L . CURRENT . ELEMENT . SYMBOL . REFERENCE  COUNT  ; = 

positive' PR£0( L .CURRENT .ELEMENT .SYMBOL . REFERENCE_COUNT ) ; 

e  1  se 

FREE^SYM  REC(l  CUHRENl  .  E  L  E  ME  NT  .  SYMBOl  ); 
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end  if; 

FREE_NODE(L. CURRENT) ; 

L.CURRENl  :=  L.TAIL; 

L.SI2E  :=  L.SIZE  -  1; 
end  DELETE; 

function  SIZE_OF(L  :  in  LIST)  return  natural  is 
--  post  -  SIZE_0F  is  the  number  of  nodes  in  list  L. 
begin 

return  (L.SIZE); 
end  SIZE_0F; 

function  EMPTY(L  :  in  LIST)  return  boolean  is 
--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is 
false. 

begin 

return  (L.HEAO  =  null); 
end  EMPTY; 

function  FULL(L  :  in  LIST)  return  boolean  is 
--  post  -  If  the  number  of  nodes  in  the  list  L  has 
allowed,  then  FULL  is  true,  else  FULL  is 
TEMPPOINTER  :  N00E_P0INTER; 
begin 

TEMP_POINTER  :=  new  NODE; 

FREE_NODE( TEMP_POINTER) ; 
return  (FALSE); 
exception 

when  STORAG  _ERR0R  => 
return  ( 1 PUE ) ; 
when  other  •> 
raise; 
end  FULL; 

function  FIh'iT(L  ;  in  LIST)  return  boolean  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  he  first  node  is  the  current  node  in 

FI RST  is  false. 

--  exceptions  raised  -  LIST  UNDERFLOW  if  L  is  empty 
begin 

if  (EMPTY(Ll)  then 
raise  L IS '  UNDERFLOW; 
end  if; 

return  (L.CjRRENT  =  L.HEAO); 
end  FIRST; 

function  LAST(L  ;  in  IISI)  return  boolean  is 

-  pre  The  list  L  IS  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L 
LAST  IS  false. 

exceptions  raised  1131  iJNUtRU.OW  it  L  is  empty 


true,  else  EMPTY  is 


reached  the  maximum 
false. 


L  then  FIRST  is  true,  else 


then  LAST  is  true,  else 
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begin 

if  (EMPTY(U))  then 
raise  LIST_UNOERFLOW; 
end  if; 

return  (L. CURRENT  =  L.TAlL); 
end  LAST ; 

procedure  CREATE(L  :  in  out  LIST;  SUCCESS  :  out  boolean)  is 

post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

begin 

L  new  LIST_INSTANCE'(null.  null,  null,  0); 

SUCCESS  ;=  TRUE; 
exception 

when  STORAGE_ERRQR  => 

SUCCESS  FALSE; 
when  others  => 
raise; 
end  CREATE; 

procedure  OISPOSE(L  ;  in  out  LIST)  is 
--  post  -  L-pre  does  not  exist, 
begin 

if  (not  EMPTY(L))  then 
FIN0_LAST(L); 
while  (not  EMPTY(L))  loop 
0£L£T£(L); 
end  loop: 
end  if; 

FREE_LIST(L); 
end  DISPOSE; 

end  ABSTRACT_SYNTAX_LIST; 

function  CREATE_DUMMY_PLACE(LA8EL  ;  in  string) 

return  LIST_NODE_POINTER  is 

--  post  -  a  place  is  created  with  a  unique  code  block  number  and  given 
a  tag  denoted  by  LABEL.  CREATE  DUMMYPLACE  returns  a  pointer 
to  a  Syntax  list  node  that  now  contains  this  place. 

LOCATION  ;  positive: 

TEMP_POINTER  :  LIST^NODE_POINTER; 
begin 

CODE_BLOCKER . ENTER_C0DE_BL0CK(0UMMy_S0URC£ ,  LABEL  ) ; 

LOCATION  :=  CODEBLOCKER . CURRENT_CODE_BLOCK_NUMfl£R; 

CODE_BLOCKER  .  EXl  T_CODE_BlOCK(OUMMY_SOURCE  )  ; 

TEMPPOINTER  :=  new  LISTNODE; 

TEMP  POINTER. PETRI  TAG  :=  PLACE; 

TEMP  POINTER. SYMBOL  : =  new  SYMBOL^TABLE.SYM  TAB  RECORD; 

TEMPPOINTER. SYMBOL .NAME  :=  (others  =>  ’  ’); 

TEMP  POINTER. SYMBOl .NAME  I ENGTH  :=  0; 
riMP  POINTER. SYMBOL. lOCAIlUN  LOCAIION; 
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TEMPPOINTER. SYMBOL. REFERENCECOUNI  :=  0; 
return  ( TEMP_POINTER) ; 
exception 

when  STORAGE  ERROR  -> 

raise  NET_GENERATOR_OVERFLOW; 
nihen  others  => 
raise: 

end  CREATE_DUMMY_PLACE; 

function  NUMBER_T0_LIST_N0DE(CURRENT_L0CATI0N  ;  in  positive) 

return  LIST_NODE_POINTER  is 

--  post  -  NUMBER_TO_LIST_NOOE  returns  a  pointer 

to  a  syntax  list  node  that  now  contains  this  place. 

TEMP_POINTER  :  LISr_NOOE_POINTER; 
begin 

TEMPPOINTER  :=  new  LIST_N00E; 

TEMPPOINTER.PETRITAG  ;=  PLACE; 

TEMP  POINTER. SYMBOL  new  SYMBOLTABLE . SYM_TAB_RECORD ; 

TEMPPOINTER. SYMBOL. NAME  :=  (others  =>  '  ); 

TEMPPOINTER. SYMBOL. NAME_L£NGrH  :=  0; 

TEMPPOINTER. SYMBOL. LOCATION  CURRENTLOCAIION; 

TEMPPOINTER. SYMBOL. R£FER£NCE_COUNT  ;=  0; 
return  ( TEMPPOINTER) ; 
exception 

when  STORAGE_ERROR 

raise  NET_GENERAT0R_0V£Rf LOW; 
when  others  *> 
raise; 

end  NUMBER_T0_LIST_N00E; 

function  POINTER_ro_LIST_NOOE( LOCATION  :  in  SYMBOL_TABLE . SfM_TAB_ACCESS) 

return  LIST_NODE_POINTER  is 

--  post  -  POINTER_TO_LlST_NOOE  returns  a  pointer 

to  a  syntax  list  node  that  now  contains  this  place. 

TEMPPOINTER  ;  LIST_NOOE_POINT£R; 
begin 

TEMP_POINTER  :=  new  LISTNODE; 

TEMPPOINTER.PETRITAG  :=  PLACE; 

TEMP_POINTER. SYMBOL  :=  LOCATION: 
return  ( TEMP_POINTER) ; 
exception 

when  ST0RAGE_ERR0R  => 

raise  NET_GENERAT0R_0VERFL0W; 
when  others  => 
raise: 

end  POINTER_TO_LIST_NOOE; 
procedure  NEWSYNTAXLIST  is 

--  pre  -  The  forest  size  has  not  reached  it's  bound. 

--  post  -  An  empty  syntax  list  is  inserted  into  the  forest  and  becomes  the 
current  element  in  the  forest. 
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TEMPSYNTAX  :  ABSTRACT_SYNTAX_LIST . LIST ; 

SUCCESS  :  boolean; 
begin 

ABSTRACT_SYNTAX_LIST . create ( TEMPSYNTAX ,  SUCCESS) ; 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERFLOW; 
end  if; 

if  (not  FOREST_LIST.FULL( FOREST))  then 
F0REST_L1ST . INSERT( FOREST,  TEMPSYNTAX ) ; 
else 

raise  NET_GENERATOR_OVERFLOW; 
end  if; 

end  NEW_SYNTAX_LIST; 

procedure  INITIALIZENETGENERATOR  is 

SUCCESS  :  boolean; 

begin 

OUMMY_SOURCE . FILE_NAM£  :=  (others  =>  ’  '); 

DUMMY_SOURCE.FILE_NAME_SIZE  :=  0; 

DUMMY_SOURCE.LINE_NUMBER  :=  0; 
ABSTRACT_SYNTAX_LIST.CREAT£(START_SYNTAX,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERFLOW; 
end  if; 

ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, 

CREATE_OUMMY_PLACE( "START" ) ) ; 
TRANSITION_POINTER  :=  new  LIST_NOOE; 
TRANSITI0N_P0rNTEfi.PETflI_TA6  :=  TRANSITION; 

TRANSITION_POINTER, SYMBOL  ;=  new  SYMB0L.TA8LE .SYM_TAB_REC0R0; 
TRANSITION_POINTER. SYMBOL  NAME  :=  (others  =>  ’  •); 
TRANSITION_POINTER. SYMBOL .NAME_LENGTH  ;=  0; 

TRANSITION_POINTER. SYMBOL. LOCATION  :=  0; 

TRANSITION_POINTER, SYMBOL. REFERENCE_COUNT  :=  0; 
ABSTRACT_SYNTAX_LIST. INSERT(START_SYNTAX.  TRANSITION^POINTER ) ; 
ABSTRACT_SYNTAX_LIST.CREATE(STOP_PLACES.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERFLOW; 
end  if; 

FORESTLI ST. CREATE (FOREST,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NETGENERATOROVERFLOW; 
end  if; 

NEST_STACX.CREATE(NS,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERFLOW; 
end  if; 

NEWSYNTAXLIST; 

exception 

when  SrORAGE_£RROR  -> 

raise  MET  GENERATOR  OVERFLOW; 
when  others  => 


166 


raise; 

end  INITIALIZE_NET_GENERATOR; 
procedure  RESET_NET_GENERATOR  is 

--  post  -  The  net  generator  is  returned  to  it's  initial  state. 

TEMPASL  ;  A8STRACT_SYNTAX_LIST . LIST ; 

SUCCESS  :  boolean; 
begin 

ABSTRACT_SYNTAX_LIST.DISPOSE(START_SYNTAX); 
if  (not  FOREST_LIST.EMPTY(FOfiEST))  then 
FOREST_L 1ST . FIN0_LAST( FOREST ) ; 
while  (not  FORESTLIST . EMPTY( FOREST ) )  loop 
FORESTL 1ST. RETRIEVE( FOREST.  TEMP_ASL); 
ABSTRACT_SYNTAX_LIST.DISPOSE(TEMP_ASL); 

FOREST_LIST.DELETE( FOREST); 
end  loop; 
end  if; 

ABSTRACT_SYNTAX_LIST.OISPOSE(STOP_PLACES); 
ABSTRACT_SYNTAX_LIST.CREATE(START_SYNTAX.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERFLOW: 
end  if; 

ABSTHACT_SYNTAX_LIST.CREATE(ST0P_PLACES,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_GENERATOR_OVERfLOy ; 
end  if; 

ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX, 

CREATE_0UMMY_PLACE( -START" ) ) ; 
TRANSniON_POINTER  :=  new  LIST_NOOE; 

TRANSITION_POINTER.PETRI_TAG  :=  TRANSITION; 

TRANSITION  POINTER. SYMBOL  :=  new  SYMBOL_TABLE .SYM_TAB_RECORD; 
TRANSITION_POINTER. SYMBOL. NAME  ;=  (others  =>  '  '); 

TRANSITIONPOINTER. SYMBOL. NAME_LENGTH  :=  0; 

TRANSITION_POINTER. SYMBOL. LOCATION  :=  0; 

TRANSITIONPOINTER. SYMBOL. REFERENCE_COUNT  :=  0; 
ABSTRACT_SYNTAX_LIST.INSERT(START_SYNTAX.  TRANSITION_POINTER) ; 
NEW_SYNTAX_LIST; 
end  RESET_NET_GENERATOR; 

function  ISCOMPLETE  return  boolean  is 

--  post  -  If  the  current  syntax  list  in  the  forest  is  empty,  then 
ISCOMPLETE  returns  true,  else  ISCOMPLETE  returns  false. 

TEMP  SYNTAX  :  ABSTRACT  SYNTAX  L 1ST . L I  ST ; 
begin 

FOREST_LIST.RETRIEVE(FOREST,  TEMPSYNTAX ) ; 
return  ( ABSTRACTSYNTAXLIST .EMPTY( TEMPSYNTAX ) ) ; 
end  IS_COMPLETE: 

procedure  INSERT_FOREST( TRANS_OR_PLACE  :  in  LIST_NOOt_POINTER)  is 
*  post  The  specified  transition  or  place  is  inserted  into  the  forest 
in  the  Current  syntax  list. 
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TEMP_LIST  :  ABSTRAC TSYNTAXLIST . LIST ; 
begin 

FOREST_LIST . RETRIEVE( FOREST ,  TEMP_LIST) ; 

ABSTRACT_SYNTAX_LIST. INSERT(TEMP_LIST.  TRANS_OR_PLAC£ ) ; 

FOREST_LIST .UPDATE ( FOREST ,  TEMPLIST ) ; 
end  INSERTFOREST; 

procedure  START( RUNUNITNAME  ;  in  SYMB0L_TA8LE.SYM_TAB_ACCESS)  is 
--  post  -  Defines  a  either  a  subprogram  place  or  task  place  that  has 
an  initial  marking  in  the  petri  net  model. 

RUN_UNIT_NOOE  :  LIST_NODE_POINTER; 

END_MARKER  :  SYMBOLTABLE . SYM_TAB_ACCESS: 
begin 

RUN_UNIT_NOOE  :=  POINTER_TO_LIST_NODE( RUM_UNIT_NAME ) ; 
ABSTRACT_SYNTAX_LIST.INSEHT(START_SYNTAX.  RUN_UNI T_NODE ) ; 

SYMBOL_TABLE . SAVE_CURRENT_ENTRY ; 

END_MARKER  :=  SYMBOL_TABLE . FIND_KEY(RUM_UMIT_NAME .NAME( 1 . . 

RUN_UNIT_NAME .NAME_LENGTH) ) 
ENDMARKER  :=  SYMBOLTABLE . SE LECT_C0MP0NENT( "END” ) ; 

ABSTRACTSYNTAXLIST . INSERT( ST0P_PLACES. 

POIMTER_TO_LIST_NODE(END_MARKER)); 

SYMBOL_TABLE . RESTORE_CURR£NT_ENTRY ; 
end  START; 

procedure  OECISION_STAfiT(START_PLACE  :  in  positive: 

ENDPLACE  :  in  SYM80L_TABLE .SYM_TAB_ACCESS)  is 
--  post  -  Oefines  a  place  that  is  the  root  place  of  a  multi-way  decision 
path  and  it's  corresponding  end  label. 

begin 

N£ST_STACK.PUSH(NS,  DEC ISI0N_R00T ) ; 

NEST_STACK.PUSH(NS,  DECISI0N_TAIL) ; 

DECISION_ROOT  ;=  NUMB£R_TO_L I ST_N00E ( START_PLACE ) ; 

DECISIONTAIL  ;=  POINTER_TO_L IST_NODE( END_PLACE ) ; 
end  0ECISI0N_START; 

procedure  DECISI0N_0R( ENDPA IHPLACE  :  in  positive)  is 
--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  starts  the 
next  path.  The  decision  start  place  is  reactivated  as  the 
current  block  number. 

START_NODE  :  LIST_N00E_P0INTER ; 
begin 

STARTNODE  :=  NUMBER_TO_l I STNODE ( ENDPAIHPLACE ) ; 
if  (not  ISCOMPLETE)  then 
INSERT_FOREST( START^NODE ) ; 

NEWSYNTAXLIST; 
end  if; 

INSERT  FOREST( STARTNODE ) : 

INSERT_fOREST( TRANSITION  POINTER) ; 

INSERT_F0Rt3T(DECIS10N_TAIL) ; 

NEW  SYNTAX  LIST; 
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COOE_BLOCKER.REACTIVATECODE_BLOCK(DECISION_ROOT. SYMBOL. LOCATION); 
end  DECISIONOR; 

procedure  EXPLICITDECISIONOR  is 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  starts  the 
next  path.  The  decision  start  place  is  reactivated  as  the 
current  block  number. 

beg  in 

if  (not  IS_COMPLETE)  then 

INSEHT_FOREST(DECISION_TAIL); 

NEW_SYNTAX_LIST; 

C0DE_8L0CKER. REACT  I VATE_CODE_BLOCK(DECISION_HOOT. SYMBOL. LOCATION); 
end  if; 

end  EXPLICIT_OECISION_OR; 

procedure  EN0_DECISI0N( ENO_PATH_PLACE  :  in  positive)  is 
--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  terminates 
the  multi-way  decision. 

STARr_N00E  :  L I ST_NODE_POINTER ; 
begin 

START_NOOE  :=  NUMBER_T0_LIST_N00E( END_PATH_PLACE ) ; 
if  (not  IS_COMPLETE)  then 
INSERT_fOREST(START_NOOE) ; 

NEW_SYNTAX_LIST; 
end  if; 

INSERT_FOREST( STARTNOOE ) ; 

INS£RT_FOREST(TRANSITION_POINTER); 

INSERT_FOREST(OECISION_rAIL); 

NEW_SYNTAX_LIST; 

INSERT_FOREST(OECISION_TAIL); 

INSERT_FOREST(TRANSIIION_POINTER); 

NEST_STACK.POP(NS,  OEC I SI0N_TAI L ) ; 

NEST_STACK.POP(NS,  OEC I SI0N_R00T ) ; 
end  EN0_0ECISI0N; 


procedure  EXPLICI T_EN0_0ECISI0N  is 

--  post  -  Ends  the  current  path  of  a  multi-way  decision  and  terminates 
the  multi-way  decision. 

begin 

if  (not  IS_COMPLETE)  then 

INSERT_FOREST( DECISION  TAIL); 

NEWSYNTAXLIST; 
end  if; 

INSERT_FORESI(OECIS10N  TAIL) ; 

I NSERT  FOREST ( TRANSIT lON  POINTER) ; 

NEST_STACX.POP(NS,  DEC  I SIONTA I L ) ; 

NESTSTACX  P0P(NS.  DECISION  ROOT); 
end  explicit  ENODECISION; 

procedure  CALL(CURRENT  lOCATION  in  positive; 

PROCtUURE  UlCAlIUN  :  in  SYMBOL_ lABl  t  SYM  lAB  ACCtSS)  is 
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--  pre  -  The  procedure  location  must  be  the  current  entry  in  the 
symbol  table. 

--  post  -  The  abstract  grammar  for  a  procedure  call  is  generated. 
START_N00E  :  LISTNODEPOINTER; 

UAITNODE  ;  LI STNODEPOINTE R ; 

TEMPPOINTER  :  SYMBOLTABL E . SYMTABACCESS ; 
begin 

STARTNOOE  NUM8ER_r0_LISTJ(00E(CURRENT_L0CATI0N) ; 

WAIT_NOOE  :=  CREATE_QUMMY_PLACE( "WAIT  RETURN"): 

SYM80L_TABLE . SAVE_CURRENT_ENTRY ; 

TEMP_POINTER  :=  SYMeOL_TABLE .SELECr_COMPONEMT( "END" ) ; 
SYMBOL_TABLE . RESTORE_CURRENT_ENTRY ; 
if  (not  IS_COMPLETE)  then 
INSERT_FOREST(STARTJIOO£); 

NEW_SYNTAX_LIST; 
end  if; 

1NSERT_FOR£ST(START_noOE) ; 

INSERT_F0REST(TRANSITI0N_P0INTER) ; 

rNS£RT_F0R£ST(P0INTER_T0_LIST_N00E(PR0CEDURE_L0CAT10N)); 

INSERT  FOREST(WAI T_N00£ ) ; 

NEW_SYNTAX_LIST; 

INSERT_FOREST(WAIT_NOOE ) ; 

INSERT_FOREST(POINTER_TO.LIST_NOOE{TEMP_POINTEB)); 
INSERT_F0R£ST(TRANSITI0N_P0INTER) ; 
end  CALL; 


procedure  ENTRY_CALL(CURRENT_l0CATI0N  :  in  positive; 

£NTRY_L0CAT10N  -.  in  SYMB0L_TABLE  .SYM_T AB_ACCESS)  is 
--  pre  -  The  entry  location  must  be  the  current  entry  in  the 
symbol  table. 

--  post  -  The  abstract  grammar  for  a  task  entry  is  generated. 

START_NOOt  :  LlST_N00t_P01NTER; 

WAITNOOE  :  L I ST_NODE_POI NTER ; 

TEMP_POINTER  :  SYM0OL_TABLE . SYM_TA8_ACCESS; 
begin 

START_N00E  :=  NUMBER_rO_LIST_NOOE(CURRENT_LOCATION) ; 

WAIT_N00E  :=  CREATEOUMMY  PLACE( "WAI T  RENDEZVOUS"); 

SYMBOLTABLE .SAVECURRENTENTRY; 

TEMPPOINTER  ;=  SYMBOL_TABLE . SELEC r_COMPONENT( "END" ) ; 

SYMBOL  TABLE  .  RESTORE  CURRENT  JNTRY ; 
if  (not  IS_C0MPLETE)  then 
INSERT_FOREST( STARINOOE ) ; 

NEW_SYNTAX  LIST; 
end  if; 

INSERT_FOREST( START  NODE  ) ; 

I NSERTFORE ST ( TRANSIT lONPOI NTER) ; 

tNSERr_FOREST(POINTER_TO  LIST  NODE (FNTRYLOCAT ION)); 

INSERT  FORESI (WAIT  NODE ); 

NEWSYHTAX  LIST ; 

INSFRT_FOREST(WAIT  NODI | ; 

INStKl  lOHLSMPOINlIR  lU  t  ISI  NOUI(  1 1 MP  PO I N  I L  R  ) ) ; 
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1 NSERT  FORES r( TRANS  1  1 1  ON _ ROI NTE H  I ; 
end  ENrRY__CALL  ; 

procedure  TASKACCE PT { CURREN I  LOCAI ION  :  in  positive; 

ENTRY  location  ;  in  positive)  is 
post  -  The  abstract  grammar  for  a  task  accept  is  generated. 
STARTNODE  :  L I S T_NOOE_PO I N TE R ; 
beg  1  n 

STARTNODE  ;=  NUMBER  TO_L I STNOOE ( CURRENTUOCAT ION ) . 
if  (not  IS_COMPLETE)  then 
INSERT_FOREST(START_NODE  ) ; 

NEW_SYNTAX_LIST; 
end  if; 

INSERT_F0R£ST(START_N00E); 

INSERT_FOREST(NUMBER_TO_LIST_NOOE(ENIRY_LOCATION) ) ; 
INSERT_FOREST(TRANSITION_POINTER) ; 
end  TASKACCEPT; 

procedure  ENOACCEP  I  { CURRENTLOCAT ION  ;  in  positive; 

ENTRYEND  in  positive)  is 

--  post  -  The  abstract  grammar  for  the  end  of  an  accept  statement  is 
generated. 

CURRENT^NODE  :  L I  ST _N0DE _P0 1 N TER ; 

L00P_P01NT£R  ;  SYM60L_TABLE . SYM_TAB_ACCESS; 
begin 

CURRENT_NO0e  ;=  NUMBER_TO_L IST_NOOE(CURRENT_LOCATION) ; 
if  (not  IS_C0MPL£TE)  then 
rNSERT_FOR£ST(CURRENT_NODE  ) ; 

NE)iI_SYNTAX_LIST; 
end  if; 

1 NSERI_f OREST ( CURREN r _N00E ); 

INSERI_f0RESr( TRANSI T [ON  POI N TER ) ; 
INSERT_F0REST(NUMB£R_T0_LIST_N00E(ENTRY_£H0) ) ; 
end  ENDACCEPT; 

procedure  EXPL I C I T_EN0_ACCE P T ( ENTRYEND  :  in  positive)  1S 

post  -  The  abstract  grammar  for  the  end  of  an  accept  statement  is 
generated . 

begin 

if  (not  IS^COMPLETE)  then 

INSERT  FORE  ST (NUMBER  TO  L I STNODE { ENTRYEND ) ) ; 
end  if; 

end  EXPLICIT  END  ACCEPI : 

procedure  GO  IO(CURRENr_lOCATION  :  in  positive; 

GOTO  LOCATION  :  in  SYMBOL  TABLE . SYM  TAB  At CE SS )  is 
post  the  abstract  grammar  for  a  goto  statement  is  geneiated. 
STAR!  NODE  :  L I S I  NODE  PC  I N TE R ; 
beg  in 

SIARI  NUDE  NUMiii  R  4)  I  I  SI  NODI  ( C  URREN I  LOCATION), 

II  I  no  1.  IS  COMPI  (III  then 


171 


INSERr_FOREST( STARTNODE ) ; 

NEW_SYNTAX_LIST; 
end  If; 

INSERf_fOREST(START_NODE ) ; 

INSERT_FOREST( TRANSIT lONPOINTER); 
INSERT_FOREST(POINTER_TO_LIST_NODE{GO_TO_LOCATION)); 
NEU_SYNTAX_LIST; 
end  GO_TO; 

procedure  ENO_LOOP( ENDLOCATION  :  in  positive: 

LOOP_START  :  in  SYMBOLTABLE . SYM_TAB_ACCESS )  is 
--  post  -  The  abstract  grammar  for  a  loop  is  generated. 

END_NODE  ;  L ISTNODE  POINTER ; 

LOOP_POINTER  :  SYMBOL_TABLE . SYMTABACCESS; 
begin 

ENDNOOE  ;=  NUMBER_TO_L ISTNODE ( ENDLOCATION ) ; 
if  (not  IS_COMPLETE)  then 
INSERT_FOREST( END_NODE ) ; 

NEWSYNIAXt 1ST; 
end  if; 

INSERT_FOREST(END_NODE): 

INSERT_FOREST(TRANSlTION_POINrER); 
INSERT_FOREST(POINTER_IO_LIST_NODE(LOOP_SIARr)); 
end  ENO_LOOP; 

procedure  CONNECT_BLOCKS(CURRENT_LOCATION  :  in  positive; 

NEXTlOCATION  :  in  positive)  is 

-  post  -  used  to  explicitly  declare  a  transition  between  two  known 

code  blocks.  The  abstract  grammar  for  a  transition  between 
two  petri  net  places  is  generated. 

STARr_N00E  :  LIST_N00E_P0INTER ; 
beg  in 

START_N00E  :=  NUMBE R_ I0_L I ST_NODE ( CURR£NT_LOC AT  ION ) ; 
if  (not  IS_COMPLETE)  then 
INSERT_FOREST(START_NOOE ) , 

NEW_SYNTAX_LIST, 
end  if; 

lNSERT_fOREST(START_NOOE) ; 

INSERT  F0REST( TRANSI T ION  POI NTER ) ; 

INSERT_F0REST(NUMBER_T0_LIST  N00E(NEXT_L0CATI0N)); 

NEW_SYNTAX_LIST; 
end  CONNECTBLOCKS: 

procedure  EXPLICIT  ENO(Ntxr_LOCAriON  :  in  positive)  is 

-  post  -  The  current  forest  is  terminated  and  a  new  forest  is  begun 
beg  1 II 

if  (not  IS^COMPLETE)  then 

INSERT  FORE  ST ( NUMBE R_ 10  I  1ST  NODE ( NE X T  LOC AT  I  ON )  )  ; 

NEW  SYNTAX  LIST; 
end  if; 

end  EXPLICI  I  END; 
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procedure  TRANSLATE_IO_PEANUT  is 

--  post  -  used  to  translate  ttie  abstract  petri  net  grammar  to  a 

text  file  used  as  an  input  file  to  P-NUT  petri  net  analyzer. 
Produces  two  files:  1)  a. out  -  P-NUT  input  file 

2)  place.dat  -  text  file  that  describes  all 
the  places  that  exist  in  the 
petri  net  and/or  the 
places  relation  to  the 
original  source  code. 

The  net  generator  and  code  blocker  are  reset  to  their 
initial  states. 

TRANSITI0N_NUMBER  :  positive  : =  1; 

NET_FILE  :  TEX T_IO . f i 1 e_type ; 

SYNTAXLIST  :  ABSTRACT_SYNTAX_L 1ST . L IST ; 

INITIAL_MARX  :  LIST_NOOE_POINTER; 

PLACE  FILE  :  TEXT  IO .  f i 1 e_type ; 

STARTSOURCEINFO  ;  TOKENSCANNER . SOURCERECORD; 

STOP _SOURCE_INFO  :  TOKENSCANNER . SOURCERECORO; 

function  P0S_T0_LIT( NUMBER  :  string)  return  string  is 
beg  i  n 

return  { NUMBER( 2 .. NUMBER ' LAST  )) ; 
end  P0S_T0_LIT; 

procedure  XLATE( SYNTAX_LIST  :  in  out  ABSTRACT_SYNTAX_LI ST . LIST )  is 
package  PLACE_STACK  is  new  GEN£RIC_STACX(LIST_NOOE_POINTER) ; 

TEMP_POINTER  :  LIST_NOOE_POINTER; 

PS  PLAC£_STACK. STACK; 

SUCCESS  :  boolean; 
beg  i  n 

PLACE_STACK.CREATE(PS.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  NET_G£N£RAT0R_0V£RFL0W; 
end  if; 

if  (not  ABSTRACr_SYNTAX_LISr.EMPTY(SYNTAX_LIST))  then 
ABSTRACT_SYNTAX_LIST.FINO_FIRST(SYNTAX_LIST); 
A8STRACT_SYNTAX_LIST.RETRIEV£(SYMTAX  LIST.  TEMP_POINTER ) ; 
while  (TEMP_POINTER.P£TRI_TAG  /-  TRANSITION)  loop 
PLACE_STACK.PUSH(PS,  TEMP  POINTER) ; 

ABSTRACT  SYNTAX_L 1ST .FIN0_NEXT( SYNTAX  LIST); 
ABSTRACT_SYNrAX_LIST.RETRIEVE(SYNTAX_LIST.  TEMPPO INTE R ) ; 
end  loop; 

ABSTRAC T _SYN TAX _L I  ST . F I NONEX T ( SYN lAXL 1ST ) ;  --skip  transition  pointer 
TEXT  JO.put(NET_FILE  .  ";t"); 

TEXT  IO.put(NET_F ILE ,  POS _ IO_L I T( pos 1 1 1 ve ' IMAGE ( TRANSI T lONNUMBER  )  ) ) ; 
TRANSITION  NUMBER  :=  TRANSITION  NUMBER  ♦  1; 
rEXT_IO.put(NFT  FUF  "); 

PLACE  STACK. ruP( PS,  TEMPPOI N I E R ) : 
lEXT  IO.put(N£T  FILE,  "p"); 

TEXT  IO.put(Nt  T_F  ILE ,  POS_ TO  I  I T ( pos 1 1 1 ve ' IMAGE ( TEMP  POI N TE R . 

SYMBOL . LOCATION)  )  1 : 

while  (Hot  PlALl  SIALK.EMPTY(PS)  )  loop 
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PLACE_STACK . POP ( PS,  lEMPPOINTER) ; 

TEXT_IO.put(NET_FILE,  ",  p"); 

TEXT  JO.put(NET_FILE.  PQS_TO_LlT(posUive  '  IMAGE(  TEMP_POINT£R  . 

SYMBOL. LOCATION))) 

end  loop; 

PLACE_STACK . OISPOSE (PS); 

TEXT_IO.put(NET_FILE,  "  ->  "); 

ABSTRACT_SYNTAX_LISr.RETRIEVE(SYNTAX_LISI,  TEMP  POINTER ) ; 
TEXT_IO.put(NET_FILE,  "p"); 

TEXT_IO.put(NET_FILE,  POS_rO_LIT(pos i t i we ' IMAGE( TEMP_POINTER . 

SYMBOL.LOCATIOM))); 

while  (not  ABSTRACTSYNTAXLISI . LAST(SYNTAX_LIST ) )  loop 
ABSTRACTSYNTAXLIST . FIN0_NEXT(SYNTAX_LIST ) ; 
ABSTRACT_SYNTAX_LIST.RETRIEVE(SYNTAX_LIST.  TEMP_P0INTER); 
TEXT_IO.put(NET_FILE.  ",  p"); 

TEXT_IO.put(NET_FILE,  POS_TO_LIT( pos i t i ve ' IMAG£( TEMPPOINTER . 

SYMBOL.LOCATIOM))) 

end  loop; 

TEXT_IO.new_1 ine( N£ r_f ILE ) ; 
end  if; 
end  XLATE; 

Pegm 

begin 

TEXT_IO.create(N£T_FILE.  TEXT_IO.out_f i le,  "a. out",  ""); 
exception 

when  IO_EXCEPTIONS.USE_£RROR  => 

T£XT_IO.open(N£T_FILE,  T£XT_tQ.out_f ile,  "a. Out”,  "”); 
when  others  =)  raise; 
end ; 

if  (not  FOREST_LIST.EMPTY{FOREST))  then 
XLATE(START_SYNrAX); 

FOREST_LlST.FIND_fIRST(FOR£ST); 

FOR£ST_LIST.RErRIEV£( FOREST,  SYNTAX_LIST ) ; 

XLATE(SYNTAX_LIST); 

while  (not  FQRESTlIST .LAST{FOREST))  loop 
FORtST_LlST,f[NO_NEXT( FOREST); 

F0REST_LIST. RETRIEVE! FOREST,  SYNTAX_L I  ST ) ; 

XLATE(SYNTAX_LIST); 
end  loop; 

ABSTRACTSYNTAXLISr. INSERT {STOP_PLACES.  TRANSI T10N_P01NTER ) ; 
ABSTRACT_SYNTAX_LIST. INSERr(STOP_PLACES,  CREATE_DUMMY_PLACE( "STOP"  ) ) ; 
XLATE(SIOP_PLACES) ; 

T£XT_IO.put(NET_FILE ,  "<p"); 

ABSTRACTSYNTAXLIST  F1NDFIRST(START_SYNTAX); 

ABSTRACT  SYNTAX  list .RETRIEVE(START_SYNTAX,  INI T I AL_MARK ) ; 

IEXT  JO.put(NET_FILE  ,  POS  TO _L I  T( pos  1 1 1 ve  '  IMAGE ( I NI T I AL  MARK  , 

SYMBOL .LOCATION) )) ; 

TEXT  10. put(NET  FILE  ,  ■'>"); 

TEXT_IO.close(NET_FILt ); 
end  if; 
begin 
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TEXT_IO.create(PLACE_FILE.  TEXT_[Q . ou t_f il e ,  "place.dat". 
exception 

when  IO_EXCEPTIONS.USE_ERROR  => 

TEXTIO  .  open(  PLACEEILE  ,  TEXTIO .  outf  1  I  e ,  "place.dat",  ; 
when  others  raise; 
end ; 

if  (not  CODEBLOCKER. IS_COOE_BLOCK_LlSr_CLEAR)  then 
COOE_BLOCKER.FIND_FIRST_CODE_BLOCK: 

TEXT_IO.put(PLACE_FILE,  "LOCATION”); 

TEXT_IO.set_coI(PLACE_FILE.  20); 

TEXT_IO. put( PLACE  FILE  .  "C00£_BL0CK_LAB£L' ) ; 

TEXT_IO.set_col(PLACE_FILE.  50); 

TEXT_IO.put(PLACE_FlL£,  "STARTING  LINE”); 

TEXT_IO.set_Co1(PLAC£_FIL£,  65); 

TEXT_IO.put(PLACE_FILE,  "ENDING  LINE”); 

TEXT_IO.new_line(PLACE_fILE.  2); 

1  oop 

TEXT_IO.put(PLAC£_FILE.  "p"); 

TEXT_IO.put(PLAC£_FILE,  POS_TO_L I T ( pos i t i ve ’ IMAGE ( C0DE_BL0CKE R . 

READ^C0DE_BL0CK_NUMBER) ) ) ; 

TEXI_IO.set_col(PLAC£_FILE.  20); 

TEXT_IO.put(PLACE_FrL£,  C00E_BL0CKER . REAOCODEBLOCKLABEL ) ; 
STARTSOURCEINFO  :=  CODE_BLOCKER.R£AO_COD£_BLOCK_START: 
STOP_SOURC£_INfO  CODE_BLOCKER.REAO_CODE_BLOCK_STOP; 
TEXT_IO.set_col(PLAC£_FILE,  55); 

TEXT_IO.put(PLACE_FIL£,  natural ' IMAGE ( START_SOURCE_INFO . LINE_NUMBER ) ) 
TEXT_IO.seC_col(PLACE_FILE,  70); 

TEXT_I0.put_l ine(PLACE_FIL£.  natural ' IMA6£(STQP_S0URCE_1MF0 . 

L1NE_NUMBER) ) 

exit  when  C0DE_BL0CKER . IS_LAST_COOE_BLOCX ; 
CODE_BLOCKER,FINO_NEXT_COOE_BLOCK; 
end  loop; 

TEXT_IO.close{PLACE_FlL£); 

COOE_BLOCKER.CLEAR_CQOE_BLOCXER; 

RESET_NET_GENERATOR; 
end  if; 

end  TRANSLATE_TO_PEANUT; 


beg  i  n 

INITIAL1ZE_NET_GENERAT0R; 
end  NETGENERATOR; 
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APPKNDIX  E 


”AI)AFLOW”  PKOGRAM  LISTING  -  SYMBOL  TABLE 


TITLE: 

ADAFLOW 

-- 

MODULE  NAME; 

PACKAGE  SYMBOLTABLE 

FILE  NAME: 

SYMTAB.ADS 

-- 

DATE  CREATED: 

01  MAR  38 

-- 

LAST  MODIFIED 

28  APR  88 

-- 

AUTHOR(S) : 

LT  ALBERT  J ,  GllECCO.  USN 

-- 

DESCRIPTION: 

This  package  contains  the  procedures  which 

define  the  interface  to  the  symbol  table. 

-- 

with  TOKEN_SCANNER; 
packagB  SYMB0L_rA8L£  is 

TYPE_OECLARATION_TAG, 
PROCEOURE_DECLARATION_TAG. 
TASK_DECLARAT10N_TAG, 

TASK_BODY_TAG, 

LABEL_NAME, 

LOOP_TAG) ; 


type  SYMBOL_TAG  is  ( OBJEC T_DECLARAT I0N_TAG . 

FUNCTION  OECLARAT I 0N_T AG. 

PACKAGE_OECLARAnON_TAG. 

ENTRY_TAG. 

PACKAGE_B0DY_TA6, 

ACCEPT_TAG, 

SELECTTAG, 


type  SYM_TAB_RECORO  is 


record 

NAME 

NAMELENGTh 
TAG_TYPE 
LOCATION 
REFERENCECOUNI 
end  record; 


s t r i ng{ 1 . . TOKENSCANNER . L INESI YE )  ;=  (others  =>  '  '); 
natural  0; 

SYMBOLTAG; 

natural  ;=  0;  --  0  indicates  undeclared, 
natural  :=  0;  -  used  to  count  the  number  of 

--  pointers  to  this  entry.  DO  NOT 
-  collect  GARBAGE  UNLESS  THIS  IS  1. 


type  SYM  lAK  ACCESS  is  access  SYM  TAB  RECORD; 
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SYMBOLTABLEOVERFLOW  ;  exception; 

DECLARATION_ERROR  ;  exception; 

REFERENCEERROR  :  exception; 

procedure  CLEAR_SYM_TAB ; 

--  post  -  SYMTAB  IS  returned  to  it's  initiaiized  state. 

function  FULL_SYM_TAB  return  boolean; 

--  post  -  If  the  size  of  SYMTAB  has  not  reached  its  bound  then  FULL  is 
FALSE  else  FULL  is  TRUE. 

procedure  EXITSCOPE; 

--  post  -  SYMTAB  backs  up  one  static  nesting  leuel .  The  current  entry  is 
defined  as  the  entry  that  caused  the  corresponding  scope  entry  to 
occur. 

procedure  INSERT_SYM_TA6( KEY  :  in  string; 

ATTRIBUTE  ;  in  SYMBOL_TAG; 

location  :  in  natural); 

--  pre  -  SYMTAB  has  not  achieved  its  maximum  allowable  size. 

--  post  -  If  the  ATTRUBUTE  IS  OBJECT_OECLARATION_TAG ,  TYPE_CECLARAT I0N_TAG , 
or  LABELNAME,  a  search  is  conducted  at  the  local  SNL  for  a 
matching  KEY.  If  no  match  is  found,  KEY  is  inserted  with  the  given 
attribute  and  location  and  is  the  the  current  entry,  else  no 
action  is  taken  and  the  current  entry  is  the  pre-existing  entry 
named  by  key. 

If  the  ATTRIBUTE  is  FUNCTION_DECLARATION_TAG, 
PROCEOURE_DECLARATION_TAG,  PACKAGE_OECLARATION_TAG , 
TASK_DECLARATION_TAG ,  or  ENTRY_TAG,  a  search  is  conducted  at  the 
local  SNL  for  a  matching  KEY.  If  no  match  is  found,  KEY  is  inserted 
with  the  given  attribute  and  location  and  scope  entry  occurs,  else 
a  check  is  made  to  see  if  the  pre-existing  entry  is  a 
PR0CE0URE_DECLARAT10N_rAG  or  a  FUNCTION_DECLARAT I0N_TA6 .  If  so, 
location  is  updated  and  scope  entry  occurs. 

If  the  ATTRIBUTE  is  PACKAGE_BOOY_TAG,  TASKBOOYTAG ,  or 
ACCEPT_TAG,  the  corresponding  environment  of  definition  i, 
located,  the  location  updated,  and  then  scope  entry  occurs. 

If  the  ATTRIBUTE  is  LOOPTAG  or  SELECTTAG,  the  symbol  is  entered 
with  the  given  ATTRIBUTE  and  LOCATION  and  scope  entry  occurs, 
exceptions  raised  -  SYMBOLTABLEOVERFLOW  if  the  symbol  table's  size 
has  reached  it's  bound. 

OECLARAT lONEHROR  if  the  required  environment  of 
definition  can  not  be  found  for  a  body  declaration 
or  if  a  declaration  tag  already  exists  at  the  current 
SNL. 

function  FIND_KEY(KEY  :  in  string)  return  SYMTABACCE SS ; 

--  post  -  If  the  symbol  table  contains  an  entry  whose  key  value  is  KEY, 
then  that  entry  is  the  current  entry  and  FIND  KEY  returns  a 
pointer  to  that  symbol  table  record,  else  FIND  KEY  returns 
a  null  pointer  and  the  current  entry  is  undefined,  NOTE 
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function 
--  post  - 


function 
--  post  - 


--  except! 


function 
--  post  - 


--  excepti 


function 
-■  post  - 


--  excepti 


procedure 
--  pie 
--  post  - 

function 

-  -  pre 

-  -  post 


the  symbol  table  IS  case  sensitive  in  it's  comparison  of  keys  and 
the  search  is  global  in  scope  according  to  ADA  visibility  rules. 

FINO_LOCAL_KEY(KEY  :  in  string)  return  SYM_TAB_ACCESS; 

If  the  symbol  table  contains  an  entry  whose  key  value  is  KEY. 
then  that  entry  is  the  current  entry  and  FIND_KEY  returns  a 
pointer  to  that  symbol  table  record,  else  fIND_KEY  returns 
a  null  pointer  and  the  current  entry  is  undefined.  NOTE  - 
the  symbol  table  IS  case  sensitive  in  it's  comparison  of  keys  and 
the  search  is  local  in  scope  according  to  ADA  visibility  rules. 

FIND_SUBPROGRAM_END  return  SYM_TAB_ACCESS; 

A  search  is  conducted  to  find  the  parent  enclosing  subprogram 
of  the  parse.  A  pointer  to  the  label  "END"  for  this  parent 
enclosing  subprogram  is  returned.  This  function  is  used  to 
provide  the  operand  for  a  'return*  statement.  The  current  entry 
is  the  corresponding  end  label  for  the  enclosing  subprogram  of  the 
parse . 

ons  raised  -  REFERENCEERROR  if  no  enclosing  subprogram  can  be 
found  or  if  a  label  "END”  can  not  be  found  for 
an  enclosing  subprogram. 

FINO_LOOP_£ND  return  SYMTABACCESS; 

A  search  is  conducted  to  find  the  enclosing  loop 
of  the  parse.  A  pointer  to  the  label  'END'  for  this 
enclosing  loop  is  returned.  This  function  is  used  to 
provide  the  operand  for  an  "exit*  statement.  The  current  entry 
IS  the  end  label  corresponding  to  the  enclosing  loop  of  the 
parse . 

ons  raised  -  R£FERENCE_ERROR  if  no  enclosing  loop  can  be 

found  or  if  a  label  'END*  can  not  be  found  for 
an  enclosing  loop. 

FIND_TASK_END  return  SYM_rAB_ACCESS; 

A  search  is  conducted  to  find  the  enclosing  task 

of  the  parse.  A  pointer  to  the  label  'END"  for  this 

enclosing  task  is  returned.  The  current  entry 

is  the  end  label  corresponding  to  the  enclosing  task  of  the 

parse . 

ons  raised  -  REFERENCEERROR  if  no  enclosing  task  can  be 

found  or  if  a  label  'END'  can  not  be  found  for 
an  enclosing  task. 

UPDATE_SYM_IAB(LOCATION  :  in  natural); 

The  current  entry  is  defined. 

The  current  entry's  location  is  changed  to  LOCATION. 

StLECT_COMPONENT(KEY  :  in  string)  return  SYMTABACC E SS ; 

The  current  entry  is  defined. 

SE I  EC T_COMPONENT  provides  visibility  to  the  next  static  nesting 
level  below  the  current  entiy.  If  the  symbol  table  contains  an 
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entry  whose  value  is  KEY  at  the  next  static  nesting  level, 
then  that  entry  is  the  current  entry  and  FINDKEY  returns  a 
pointer  to  that  symbol  table  record,  else  FINDKEY  returns 
a  null  pointer  and  the  current  entry  is  undefined.  NOTE  - 
the  symbol  table  IS  case  sensitive  in  it's  comparison  of  Keys. 

function  RETRIEVE_SYM  return  SYM_TA8_ACCESS; 

--  post  -  RETRIEVE  SYM  returns  a  pointer  to  the  current  entry  or  null  if 
the  current  entry  is  undefined. 

procedure  SAVE_CURRENI_ENTRY ; 

--  pre  -  The  current  entry  is  defined; 

--  post  -  The  current  entry  is  saved  in  a  last  in  first  out  data  structure. 

procedure  REST0R£_CURRENT_ENTRY : 

--  pre  -  A  current  entry  was  saved; 

--  post  -  The  last  current  entry  saved  is  the  current  entry. 

procedure  PRINT_SYMBOL_rABL£ : 

--  post  -  Useful  as  a  debugging  tool,  PRINT_SYMBOL_TABLE  prints  a  dump  of 
every  symbol  table  entry,  including  attribute  and  location 
information,  to  the  standard  output  device. 

end  SYMBOL_TABLE; 
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TITLE: 

AOAFLOW 

MODULE  NAME: 

PACKAGE  SYMB0L_TA8LE 

-- 

FILE  NAME: 

SYMTAB.AOB 

-- 

DATE  CREATED: 

01  MAR  88 

__ 

LAST  MODIFIED: 

28  APR  88 

-- 

AUTHOR(S) : 

LT  ALBERT  J.  GRECCO,  USN 

-- 

DESCRIPTION: 

This  package  contains  the  procedures  which 
implement  the  interface  to  the  symbol  table. 

-- 

with  TOKEN_SCANNER, 

GENERIC_STACK, 

UNCHECKEO_DEALLOCATION, 

TEXTIO; 

package  body  SYMBOLTABLE  is 

procedure  FREE_SYM_REC  is  new 

UNCHECkED_DEALLOCAnON(SYM_TAB_RECORD,SYM_7AB_ACCESS); 
subtype  OEf INITION_TAGS  is  SYMBOL_TAG  range 

FUNCTI0N_0£CLARATI0N_rAG. .ENTRY_TAG: 
subtype  B00Y_TAGS  is  SYMBQL_TAG  range  PACICAGt_800Y_TAG .  .ACCEPT_TAG; 

type  LIST_N0De; 

type  LIST_NODE_POINTER  is  access  LISTNOOE; 
package  SYMBOL_LIST  is 

type  LISTINSTANCE  is  private; 

type  LIST  is  access  LISI_1NSTANCE ; 

L ISTOVERFLOU  :  exception; 

LIST_UN0ERFL0W  :  exception; 

--  Operations:  If  the  list  is  not  empty,  then  one  of  the  nodes  is  designated 
as  the  current  node.  Ocaasionatty.  in  the  postcondition,  it  is  necessary 
to  refer  to  the  list  of  the  current  node  as  they  were  immediately  before 
execution  of  the  operation.  1 -pre  and  c-pre,  respectively,  are  employed 
for  these  references. 

procedure  FINO_F[RSr(L  in  out  LISI); 

-  pre  -  The  list  1  is  not  empty 
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--  post  -  The  first  node  is  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

procedure  FIND_NEXT{L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
--  post  -  c-next  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNOEHFLOW  if  L  is  empty. 

-  LISTOVERFLOW  if  the  last  node  is  the  current  node. 

procedure  FIND_PREVIOUS(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOU  if  L  is  empty  or  c  is  the  first  node. 

procedure  fINO_LAST(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTJJNOERFLOW  if  L  is  empty. 

procedure  RETRIEVE(L  :  in  LIST;  ITEM  ;  out  LISTNOOEPOINTER) ; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LIST_UNOERFLOW  if  L  is  empty. 

procedure  UP0ATE(L  ;  in  out  LIST;  ITEM  ;  in  LIST_NOUE_POIMTER) ; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  current  node  in  L  contains  ITEM  as  its  element. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

procedure  INS£RT(L  ;  in  out  LIST;  ITEM  ;  in  LIST_NOOE_POINTER ) ; 

--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 

node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 

ITEM  is  the  current  node. 

--  exceptions  raised  -  LISTOVERFLOW  if  L  has  reached  its  bound. 

procedure  DELETE(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  cpre  was  the  first  node, 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node, 
exceptions  raised  LISTUNDERFLOW  if  L  is  empty. 

function  SIZE_0F(L  ;  in  LIST)  return  natural; 

-  post  -  SIZEOF  IS  the  number  of  nodes  in  list  L. 

function  EMPTY(L  ;  in  LIST)  return  boolean: 

post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 
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function  FULL(L  ;  in  LIST)  return  boolean; 

--  post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

function  FIRST(L  :  in  LIST)  return  boolean: 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  first  node  is  the  current  node  in  L  then  FIRST  is  true,  else 
FIRST  is  false. 

--  exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty. 

function  LAST(L  :  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LAST  is  false. 

--  exceptions  raised  -  LISTUNDERF LOW  if  L  is  empty. 

procedure  CREATE(L  :  in  out  LIST;  SUCCESS  :  out  boolean); 

--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

procedure  DISP0SE(L  :  in  out  LIST); 

--  post  -  L-pre  does  not  exist. 

procedure  ASSIGN(L1  :  in  LIST;  L2  :  in  out  LIST); 

--  post  -  L2  contains  the  same  nodes  as  LI. 

procedure  SAVE_LIST(L  ;  in  LIST); 

-■  post  -  L  is  saved  in  a  last  in  first  out  data  structure. 

procedure  REST0R£_L IST( L  :  in  out  LIST); 
post  -  L  is  the  last  list  that  was  saved. 


private 


type  NODE, 

type  NOOEPOINTER  is  access  NOOE; 
type  NOOE  is 
record 

ELEMENT  :  L I STNOOEPOIN T£ R ; 

NEXT  :  NOOEPOINTER, 
end  record; 
type  LISTINSTANCE  is 
record 


HEAD 

TAIL 

CURRENT 

SIZE 


NOOE  POINTER  ;  =  null 
N00E_P0INTER  null 
NOOEPOINTER  :=  null 
natural  .  -  0 : 


end  record 


end  SYMBOL  LIST ; 


type  LISTNODE  is 
record 
SYMBOL 
SUB_LIST 
end  record; 


:  SyM_TAB_ACCESS; 

:  SYMBOL_LIST.LIST; 


SYM_rAB 
CURREMTSNL 
SEARCH  SNL 


SYMBOLLISE . LIST;  --  the  root  of  the  symbol  table  tree 
SYMBOLLIST . LIST;  --  keeps  track  of  the  current  branch 
SYMBOLLIST . LIST;  --  can  be  operated  on  without  effecting 
--  the  state  of  the  symbol  table. 


LASTFOUND  :  LIST_NODE_POINTER  ;=  null; 

package  STK  OF  LISTS  is  new  GENERIC_STACI((SYMBOL_LIST.LIST) ; 

SCOPE_STACK  ;  STK_OF_LISTS. STACK; 
package  body  SYMBOLLIST  is 

procedure  FREENOOE  is  new  UNCHECKEO_DEALLOCATION(NODE.  NODE_POINTER) ; 
procedure  FHEE_LIST  is  new  UNCHECKED_DEALLOCATION(LIST_INSTANCE ,  LIST); 
procedure  FREE_SYM_R£C  is  new 

UNCHECKE0_0EALL0CATI0N(SYM_TA8_REC0RD.SYM_TAB_ACCESS) ; 
package  STACK_LIST_tNSTANCES  is  new  GENERIC_STACK(LIST ) ; 

SLI  :  STACK_LIST_INSTANCES. STACK; 

SUCCESS  :  boolean; 

procedure  FIND_FIRST(L  :  in  out  LIST)  is 
pre  -  The  list  L  is  not  empty. 

--  post  -  The  first  node  is  the  current  node. 

--  exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty, 
beg  i  n 

if  (EMPrY(L))  then 
raisu  LlSTUNOERFLOW; 
end  if; 

L. CURRENT  ;=  L.HEAO; 
end  FIND_fIRST; 

procedure  F1N0_NEXT(L  :  in  out  LIST)  is 

pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node 
--  post  -  c-next  in  L  is  the  current  node. 

■  exceptions  raised  -  LlSTUNOERFLOW  if  L  is  empty. 

-  LIST  OVERFLOW  if  the  last  node  is  the  current  node. 

beg  in 

if  (tMPTY(L))  then 
raise  L I STUNOERFLOW ; 
end  if; 

if  (LASt(L))  then 
raise  LISI_0VERFL0W; 
end  if; 
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L. CURRENT  ■.  =  L  . CURRENT  . NEXT  ; 
end  FIND_NEXT; 

procedure  F  IND_PREVIOUS(  L  :  in  out  LIST)  is 

--  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  L ISTUNDERFLOW  if  L  is  empty  or  c  is  the  first  node. 

TEMPPOINTER  :  NOOEPOI NTER ; 

begin 

if  (EMPTY(L)  or  FtRST(L))  then 
raise  LISTUNOERFLOW; 
end  if; 

TEMPPOINTER  L.HEAO; 

while  (TEMP_POINTER.N£XT  /=  L. CURRENT)  loop 
TEMP_POINTER  ;=  TEMP_POINTER . NEXT ; 
end  loop; 

L. CURRENT  :=  TEMPPOINTER ; 
end  FINOPREVIOUS; 

procedure  fIND_LAST(L  :  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  LIST_UN0ERFL0W  if  L  is  empty, 
begin 

if  (EMPTY(L))  then 
raise  LIST_UN0£RFL0W; 
end  if; 

while  (not  LAST{ L  ) )  loop 
FINO_.icXT(L); 
end  loop; 
end  FIN0_LAST; 

procedure  RETRI£VE(L  ;  in  LIST;  ITEM  ;  out  L 1ST _NOO£_POI NTER )  is 
pre  -  The  list  L  is  not  empty. 

post  -  ITEM  contains  the  value  of  the  element  in  the  current  node, 
exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty 
beg  i  n 

if  (£MPTY(L))  then 
raise  LIST_UN0ERFL0W; 
end  i  f  ; 

ITEM  :=  L. CURRENT  ELEMENl; 
end  RETRIEVE; 

procedure  UPOATE(l  :  m  out  LIST;  ITEM  :  in  L ISI _NOOE_POINTER )  is 
'  pre  -  The  list  L  is  not  empty. 

-  post  Ihe  current  node  in  L  contains  ITEM  as  its  element, 
exceptions  raised  LlSl  UNDERFLOW  if  L  is  empty, 
beg  1  n 

if  (EMPIYID)  then 

raise  I  1 jl  UNDERElOW: 

-ind  1  f  : 
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L. CURRENT. ELEMENT  :=  ITEM; 
end  UPDATE; 

procedure  1NSERT(L  ;  in  out  LIST;  ITEM  ;  in  LIST_NODE_POI N TER )  is 

--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 

node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 

ITEM  is  the  current  node. 

--  exceptions  raised  -  LISTOVERE LOW  if  L  has  reached  its  bound. 

TEMP_POINTER  ;  NOOE_POINTER ; 

begin 

if  (FULL(L))  then 
raise  LISTOVERFLOW; 
end  if; 

TEMP_POINTER  ;=  new  N0DE’(ITEM.  null); 

TEMPPOINTER . ELEMENT , SYMBOL , REFERENCE_COUMT  ; = 

natural ' SUCC( TEMPPOINTER . ELEMENT . SYMBOL . RE FERENCE_COUNT ) ; 
if  ( L . HEAD  =  null)  then 
L.HEAD  :=  TEMPPOINTER ; 

L.TAIL  ;=  TEMP_POINTER; 
else 

L.TAIL. NEXT  ;=  TEMP_P01 NTER ; 

L.TAIL  :=  TEMP_POINTER; 

end  if; 

L. CURRENT  ;=  T£MP_POI NTER ; 

L.SIZE  ;=  L.SIZE  *  1; 
end  INSERT; 

procedure  0ELETE(L  ;  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node. 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty. 

TEMP_POINTER  ;  NOOEPOI NTER ; 
beg  i  n 

if  (EMPTY(L))  then 
raise  LISTUNDERFLOW; 
end  if; 

If  (L. CURRENT  /=  L.HEAD)  then 
TEMPPOINTER  :=  L.HEAD; 

while  (TEMP  POINTER.NEXT  /-  L. CURRENT)  loop 
TEMPPOINTER  ;=  TEMPPOIN TER . NEXT ; 
end  loop; 

TEMPPOINTER.NEXT  ;=  L , CURRENT . NEX T ; 
if  (L. CURRENT  =  L.TAIL)  then 
L.TAIL  ;=  TEMP  POINTER; 
end  if; 
e  I  se 

if  (L .HEAD  =  L.TAIL)  then 
L  .  lAU  ;  ■  nut  1  ; 
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end  if; 

L.HEAD  :=  L. HEAD. NEXT; 
end  if; 

if  (L. CURRENT. ELEMENT. SYMBOL. REFERENCE_COUNT  >  1)  then 
L .CURRENT .ELEMENT . SYMBOL . REf EREMCECOUNT  ; = 

pos It ive'PREO(L. CURRENT. ELEMENT. SYMBOL. REF ERENCE_COUNT ) ; 

e  I  se 

FREE_SYM_REC(L. CURRENT. ELEMENT. SYMBOL); 
end  if; 

DISPOSE(L .CURRENT. ELEMENT. SUB_LIST); 

FREE_NODE(L. CURRENT): 

L. CURRENT  :=  L.TAIL; 

L.SIZE  ;=  L.SI2E  -  1; 
end  DELETE; 

function  SI2E_OF(L  :  in  LIST)  return  natural  is 
--  post  -  SIZEOF  is  the  number  of  nodes  in  list  L. 
beg  i  n 

return  (L.SIZE): 
end  SIZE_Of; 

function  £MPTY(L  :  in  LIST)  return  boolean  is 

--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 

begin 

return  (L.HEAO  =  null); 
end  EMPTY; 

function  FULL{L  :  in  LIST)  return  boolean  is 

--  post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  manimum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

TEMPPOINTER  :  NODE_POINTER; 
beg  i  n 

TEMP_POINTER  :=  new  NODE; 

FREE_N0QE(TEMP_P01NTER); 
return  (FALSE); 
exception 

when  STORAGE_ERROR  O 
return  (TRUE); 
when  others  => 
raise; 
end  FULL; 

function  FIRST(L  ;  in  LIST)  return  boolean  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  first  node  is  the  current  node  in  L  then  FIRST  is  true,  els 
FIRST  i s  f  a  I se . 

--  exceptions  raised  LISTUNDERF LOW  if  L  is  empty, 
beg  i  n 

if  (EMPTY(L))  then 

raise  L  IS!  IINOI  Hi  I  OW; 
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end  '  f  ; 

return  (L. CURRENT  =  L.HEAD); 
end  FIRST; 

function  LAST(L  :  in  LIST)  return  boolean  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LAST  is  false. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty, 
begin 

if  (EMPTY(L))  then 
raise  LIST_UNDERFLOW; 
end  if; 

return  (L. CURRENT  =  L.TAIL); 
end  LAST ; 


procedure  CREATE(L  ;  in  out  LIST;  SUCCESS  :  out  boolean)  is 
--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

beg  1  n 

L  :=  new  LISTINSTANCE ' ( nul I .  null,  null.  0); 

SUCCESS  ;=  TRUE; 
exception 

when  STORAGE_EhROR  => 

SUCCESS  ;=  FALSE; 

when  others  => 
raise; 
end  CREATE; 

procedure  0ISP0SE(L  :  in  out  LIST)  is 
--  post  -  L-pre  does  not  exist, 
begin 

if  (not  EMPTY(L))  then 
F1N0_LAST(L); 
while  (not  EMPTY(L))  loop 
DELETE(L); 
end  loop; 

end  if; 

FREE_LIST(L) ; 
end  DISPOSE; 


procedure  ASSIGN(L1  :  in  LIST;  L2  :  in  out  LIST) 
--  post  -  L2  contains  the  same  nodes  as  LI. 
beg  in 


L2 .HEAD 
L2. CURRENT 
L2 .TAIL 
L2  .SUE 
end  ASSIGN; 


LI. HEAD; 

LI  .CURRENT; 
LI .TAIL; 

LI. SIZE; 


is 
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procedure  SAVE_LIST(L  :  in  LIST)  is 

--  post  -  L  IS  saved  in  a  last  in  first  out  data  structure. 

TEMPLIST  :  LIST; 

SUCCESS  :  Poolean; 
begin 

CREATE( TEMPLIST,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOL_TABLE_OVERFLOU; 
end  if; 

ASSIGN(L,  TEMP_LIST): 

STACK_LIST_INSTANC£S . PUSH{ SLI .  TEMPLIST ) ; 
end  SAVE_LIST; 

procedure  RESTORE_LIST( L  :  in  out  LIST)  is 
--  post  -  L  is  the  last  list  that  was  saved. 

TEMPLIST  :  LIST; 
beg  i  n 

STACK_LIST_INSTANCES.P0P(SLI .  TEMPLIST) ; 

ASSIGN(TEMP_LIST.  L); 

FR£E_LIST(T£MP_LIST); 
end  REST0R£_LIST; 

begin 

SrACK_LIST_INSTANC£S.CREATE(SLI ,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMB0L_TA8L£_0VERFL0W ; 
end  if; 

end  SYMBOL_LIST; 

function  SNL_SEARCH(KEY  ;  in  String)  return  LIST_NOD£_POINTER  is 
--  post  -  If  the  symbol  table  contains  an  entry  at  the  local  scope  whose 
key  value  is  KEY,  then  that  entry  is  the  current  entry  in  the 
list  SEARCHSNL  and  SNL_SEARCH  returns  a  pointer  to  that  list 
node,  else  SNL_SEARCH  returns  a  null  pointer  and  the 
current  entry  in  the  list  SEARCHSNL  is  the  last  entry, 
SEARCHPOINTER  ;  LIST_NODE_POINTER; 
beg  in 

if  (SYM60L_LIST.EMPTY(SEARCH_SNL))  then 
return  (  nul  1  ) ; 
e  I  se 

SYMBOL  LIST.  FIND  FIRST (SEARCH_SI4L) ; 

1  OOP 

SYMBOL_LIST.RETRIEVE(SEARCH_SNL,  SEAHCHPOI NT E R ) : 
if  ((SEARCH_POINTER.SYMBOL .NAMELENGTH  =  KEY'LENGTH)  and  then 
(SEARCHPOINTER. SYMBOL. NAME(1. ,KEY'LAST)  =  KEY))  then 
return  ( SEARCHPOI NTER ) ; 
else 

exit  when  ( SYMBOL  L 1  SI . LAST( SEARCH  SNL )) ; 

SYMBOL _L I  ST. FIND  NEK T( SEARCH  SNL); 
end  if; 
end  loop; 
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return  (null); 
end  if; 

end  SNL^SEARCH; 

procedure  INI TI ALI ZE_SYM_TAB  is 

--  post  -  SYM_TAB  contains  the  names  and  defined  attributes  for  the  language 
defined  enclosing  scopes. 

SUCCESS  ;  boolean: 
begin 

SYMBOL_LIST .CREATE( SYM_rAB ,  SUCCESS) ; 
if  (not  SUCCESS)  then 
raise  SYMBOL_TABLE_OVERFLOW; 
end  if; 

SYMBOL_LI ST . CREATE ( SEARCHSNL ,  SUCCESS ) ; 
if  (not  SUCCESS)  then 

raise  SYMB0L_TA8LE_0VERFL0U ; 
end  if; 

STK_Of_LISTS.CREATE(SCOPE_STACK,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOL_TABLE_OVERFLOU ; 
end  if; 

CURRENT_SNL  :=  SYMIAB; 
end  INITIALIZE_SYM_TAB; 

procedure  CLEAR_SYM_TA8  is 

--  post  -  SYM_TA8  is  returned  to  it's  initialized  state. 

SUCCESS  ;  boolean; 
begin 

SYM80L_L 1ST .DISPOSE ( SYM_TA8 ) ; 

STK_OF_LISTS.DISPOSE(SCOP£_STACK); 

SYMBOL_L 1ST. CREATE (SYM_TA8,  SUCCESS): 
if  (not  SUCCESS)  then 
raise  SYM80L_TA8LE_0VERFL0W; 
end  if; 

STK_0F_L I  STS. CREATE (SC0PE_3TACK.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYM80L_TA8LE_0VERFL0W; 
end  if; 

CURRENTSNL  SYM_TA8; 

LASTFOUND  : =  null; 
end  CLEAR_SYM_TA8: 

function  FULL  SYM  TAB  return  boolean  is 

--  post  -  If  the  size  of  SYMTAB  has  not  reached  ils  bound  then  FULL  is 
FALSE  else  FULL  is  TRUE. 

begin 

return  (SYMBOL_LIST.FULL(CURRENI  SNl )); 
end  FULL  SYM  TAB; 

procedure  ENTER  SCOPE  is 

post  SYM  lAB  enters  the  next  .tatic  nesting  level. 
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TEMP_P01NTER  :  L I ST_NOOE_POIN TER ; 
begin 

STK_OF_L I  STS . PUSH( SCOPE_STACK ,  CURRENr_SNL ) ; 

SYi<30L_LIST.RETRIEVE(SEARCH_SNL,  TtMP_POINTEfi) ; 

CURRENT  SNL  TEMP  POINTER . SUB_L I  ST ; 

SYMBOLLIST .ASSIGN(CURRENT_SNL,  SEARCHSNL); 
end  ENTER_SCOPE; 

procedure  ENTER_SEARCH_SCOPE  is 

--  post  -  SYMTAB  enters  the  next  static  nesting  level. 

TEMP  POINTER  :  LIST_NODE_POINTER; 
begin 

SYMBOL  LI  ST. RETRIEVE (SEARCHSNL,  TEMPPOINTER) ; 

SYMB0L_LIST.ASSIGL'’-EMP_P0INTER.SU8_LlSr.  SEARCH  SNL  ) ; 
end  ENTER_SEARCH_SCaE^ 

procedure  EXITSCOPE  is 

--  post  -  SYMTAB  backs  up  one  static  nesting  level.  The  current  entry  is 
defined  as  the  entry  that  caused  the  corresponding  scope  entry  to 
occur. 

TEMPPOINTER  :  L IST_NOOE_POINTER ; 
begin 

STX_OE_LISTS.POP(SCOPE_STACK.  CURRENTSNL ) ; 

SYMBOL_LI ST . ASSIGN( CURRENTSNL ,  SE ARCHSNL ) ; 

SYMBOL_LIST.RETRIEV£(SEARCH_SNL.  LAST_fOUNO); 
end  EXIT_SCOPE: 

procedure  INS£RT_SYM_rAB( KEY  ;  in  string; 

ATTRIBUTE  :  in  SYMBOL_TAG; 

LOCATION  :  in  natural)  is 

--  pre  -  SYM_TAB  has  not  achieved  its  manimura  allowable  size. 

--  post  -  If  the  ATTRUBUTE  is  OBJECT_DECLARATION_TAG ,  TYPE_CECLARATION_TAG . 
or  LA8EL_NAME.  a  search  is  conducted  at  the  local  SNL  for  a 
matching  KEY.  If  no  match  is  found,  KEY  is  inserted  with  the  given 
attribute  and  location  and  is  the  the  current  entry,  else  no 
action  is  taken  and  the  current  entry  is  the  pre-existing  entry 
named  by  key. 

If  the  ATTRIBUTE  is  FUNC I ION_DECLARATION_TAG , 
PROCEDURE_OECLARATION_TAG,  PACKAGEOECLARATIONTAG , 
TASK_DECLARATION_rAG ,  or  ENTRYTAG.  a  search  is  conducted  at  the 
local  SNL  for  a  matching  KEY  If  no  match  is  found,  KEY  is  inserted 
with  the  given  attribute  and  location  and  scope  entry  occurs,  else 
a  check  is  made  to  see  if  the  pre-existing  entry  is  a 
PROCEOURE_DECLARATION_TAG  or  a  FUNCTION_OECLARATION_TAG ,  If  so, 
location  is  updated  and  scope  entry  occurs. 

If  the  ATTRIBUTE  is  PACKAGE_BOOY_IAG ,  TASK  BODYTAG,  or 
ACCEPTTAG,  the  corresponding  environment  of  definition  is 
located,  the  location  updated,  and  then  scope  entry  occurs. 

If  the  ATTRIBUTE  is  LOOPTAG  or  SELECTTAG,  the  symbol  is  entered 
with  the  given  ATTRIBUTE  and  LOCATION  and  scope  entry  occurs, 
‘.'xceptions  raised  -  SYMBOl  lABI  t  OVERFLOW  if  the  symbol  table's  size 
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has  reached  it's  bound. 

OECLARATIONERROR  if  the  required  environment  of 
definition  can  not  be  found  for  a  body  declaration 
or  if  a  declaration  tag  already  exists  at  the  current 
SNL. 

TEMPPOINTER  :  LISTNODEPOINTER ; 

SEARCHPOINTER  ;  L I ST_N0DE_P0I NTER ; 

TEMPSYMBOL  :  SYMTABACCESS; 

SUCCESS  :  boolean; 
use  SYMBOLLIST; 
begin 

if  ((ATTRIBUTE  =  OBJECT_OECLARATION_TAG )  or  else 

(ATTRIBUTE  =  TYPE_OECLARATION_TAG )  or  else  (ATTRIBUTE  =  LABEL_NAME))  then 
SYMBOL_LIST.ASSIGN(CURRENT_SNL,  SEARCH_SNL); 

SEARCH_POINTER  ; =  SNL_SEARCH( KEY ) ; 
if  (SEARCH_POINTER  =  null)  then 

if  (not  SYMBQL_LIST.FULL(CURRENT_SNL))  then 
TEMPPOINTER  :=  new  LISTNOOE; 

TEMPPOINTER. SYMBOL  :=  new  SYM_TA8_REC0RD ; 

TEMPPOINTER. SYMBOL .NAME_LEN6TH  ;=  KEY’LENGTH; 

TEMPPOINTER. SYMBOL. NAME  :=  (others  =>  '  '); 

TEMP_POINTER. SYMBOL. NAME( 1. .KEY'LAST)  :=  KEY; 

TEMPPOINTER. SYMBOL. TAG_TYPE  :=  ATTRIBUTE; 

TEMPPOINTER. SYMBOL. LOCATION  :=  LOCATION; 

TEMP_POINTER.  SYMBOL.  REFERENCE_COUNT  :=>  0; 

SYMBOL_LIST.CREAT£( T£MP_POINTER.SUB_LISI.  SUCCESS); 
if  (not  SUCCESS)  then 
raise  SYMBOL_TABLE_OVERf LOW; 
end  if; 

SYMB0L_LIST. INS£Rr(CURR£NT_SNL.  T£MP_POINTER) ; 

SYMBOL_L I S t . ASS IGN( CURRENT_SML .  SE ARCH_SNL ) ; 

LAST_FOUNO  :=  TEMP_POINTER ; 
el  se 

raise  SYMB0L_TABL£_0VERFL0W; 
end  if; 
e  1  se 

SYMBOLL I  ST .ASSIGN( CURRENT  SNL.  SEARCHSNL ) ; 

LAST_FOUND  :=  SEARCH^POIN lER ; 
end  if; 

elsif  (ATTRIBUTE  in  OE F INI T lONTAGS)  then 
SYMBOL_L 1ST. ASSIGN( CURREN T  SNL ,  SEARCH_SNL ) ; 

SEARCH_P01NTER  SNL_SE ARCH( KEY ) ; 
if  (SEARCHPOINTER  =  null)  then 

if  (not  SYMBOLLIST .FULL(CURRENT_SNL))  then 
TEMPPOINTER  ;=  new  LISTNOOE; 

T£MP_POINTER. SYMBOL  :=  new  SYM_TA8_R£CORD ; 

TEMPPOINTER. SYMBOL. NAMELENGTH  KEY'LENGTH; 

TEMPPOINTER. SYMBOL. NAME  (others  =>  '  '); 

TEMPPOINTER. SYMBOL .NAME( 1 . .KEY'LAST)  ;=  KEY; 

TEMP  POINTER. SYMBOL. TAG  TYPE  ;=  ATTRIBUTE; 

TEMP  POINTER. SYMBOL . I  OCAIION  LOCATION; 


191 


TEMP_POINTER. SYMBOL. REFERENCE  COUNT  0: 

SYMBOL_LIST .CREATE( TEMPPOINTER . SU8_LIST ,  SUCCESS ) ; 
if  (not  SUCCESS)  then 

raise  SYMBOL_TABLE_OVERFLOW; 
end  if; 

SYMBOL_LIST. I NSERT( CURRENT _SNL,  TEMPPOINTER  ) ; 

SYMBOL_LI ST . ASSIGN( CURRENTSNL .  SEARCHSNL ) ; 

LAST_FOUND  :=  TEMP_POINTER; 

ENTERSCOPE; 

else 

raise  SYMBOL_TABLE_OVERFLOW: 
end  if; 

elsif  ((ATTRIBUTE  =  FUNCTION  OECLARATION_TAG)  or 

(ATTRIBUTE  =  PROCEOURE_DECLARATION_TAG) )  then 
UPOATE_SYM_TAB( LOCATION ) ; 

SYMBOL_LIST.ASSIGN(SEARCH_SNL,  CURRENT  SNL ) ; 

LASTFOUND  ;=  SEARCHPOINTER ; 

ENT£R_SCOPE; 
e  I  se 

raise  DECLARATION_ERROR; 
end  if; 

elsif  (ATTRIBUTE  in  BOOYTAGS)  then 

SYM80L_LIST.ASSIGN(CURRENT_SNL,  SEARCH_SNL); 

TEMP_SYMBOL  ;=  F IN0_KEY( KEY ) ; 
if  (TEMP_SYMBOL  =  null)  then 
LAST_FOUNO  ;=  null; 
raise  DECLARAT ION_ERROR ; 
else 

UPDATE_SYM_TAB(LOCATION); 
if  (SEARCH_SNL  =  CURRENT_SNL)  then 

SYMBOL_LIST .ASSIGN(SEARCH_SNL,  CURREN r_SNL ) ; 
end  if; 

SYMBOL_L 1ST  RE TRI EVE ( SEARCH  SNL  ,  L AST  FOUND ) ; 

ENTER_SCOPE; 
end  if; 

elsif  ((ATTRIBUTE  =  LOOP_TAG)  or  else  (ATTRIBUTE  =  SELECT_TAG))  then 
if  (not  SYMBOL_LIST.FULL(CURRENT_SNL))  then 
TEMPPOINTER  ;=  new  LISTNODE; 

TEMPPOINTER. SYMBOL  ;=  new  SYMTAB  RECORD; 

TEMPPOINTER. SYMBOL. NAMELENGTH  ;=  KEY'LENGTH; 

TEMPPOINTER. SYMBOL. NAME  :=  (others  ->  '  '): 

TEMP  POINTER. SYMBOL. NAME(1.  .KEY'LASI)  :=  KEY; 

TEMPPOINTER. SYMBOL. TAGTYPE  ;=  ATTRIBUTE; 

TEMPPOINTER. SYMBOL. LOCATION  ;=  LOCATION; 

TEMPPOINTER. SYMBOL. REFERENCE_COUNT  ;=  0; 

SYMBOLL I  ST. CRE ATE ( TEMP  POINTER. SUBL 1ST,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOL  TABLE  OVERFLOW; 
end  i f ; 

SYMBOL  1  1ST . INSERr(CURRENr  SNL  .  TEMP  POINTE R ) ; 

SYMBOL  L ISr  ASS  I GN( CURREN TSNL,  SEARCH  SNL ) ; 
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LASTFOUND  :=  TEMPPOINTER ; 

ENTER_SCOPE: 

else 

raise  SYMBOLTABLEOVERFLOW ; 
end  if; 
end  1 f : 
exception 

when  ST0RAGE_ERR0R  => 

raise  SYMBOL_TABLE_OVERFLOW-. 
when  others  -> 
raise; 

end  INSERTSYMTAB; 

function  FIND_KEY(KEY  :  in  string)  return  SYM_TAB_ACCESS  is 
--  post  -  If  the  symbol  table  contains  an  entry  whose  key  value  is  KEY, 
then  that  entry  is  the  current  entry  and  FIND_KEY  returns  a 
pointer  to  that  symbol  table  record,  else  FINDKEY  returns 
a  null  pointer  and  the  current  entry  is  undefined.  NOTE  - 
the  symbol  table  IS  case  sensitive  in  it's  comparison  of  keys  and 
the  search  is  global  in  scope  according  to  ADA  visibility  rules. 
TEMPPOINTER  :  LIST_NOOE_POINTER; 

TEMPLIST  :  SYMBOL_LIST.LIST; 

SEARCH_STACK  :  STK_0F_L I  STS . STACK ; 

SUCCESS  :  boolean; 
begin 

STK_0F_LISTS.CREATE(SEARCH_STACK,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOL_TABLE_OVERf LOW; 
end  if; 

SYMBOL_LIST . ASSIGN(CURRENT_SNL ,  SEARCHSNL) ; 

TEMP_POINTER  :=  SNL_SEARCH( KEY ) ; 
if  ( TEMP_POINTER  /=  null)  then 
LAST_F0UND  :=  TEMP_POINTER; 
return  ( rEMP_POINTER . SYMBOL  ) ; 
else 

while  (not  STK_0f_L ISTS . EMPTY( SCOPE_STACK ) )  loop 
STK  OFLISTS . POP( SCOPE_STACK ,  TEMP_LIST ) ; 
STK_0F_L1STS.PUSH(SEARCH_STACK,  TEMPLIST); 

SYMBOL_LIST . ASSIGN( TEMPLIST ,  SEARCHSNL ) ; 

TEMPPOINTER  ;=  SNL_SE ARCH( KEY ) ; 
if  (TEMP  POINTER  null)  then 
while  (not  STKOFL ISIS . EMPTY( SEARCHSTACK ) )  loop 
STK  OF  LI  STS . POP( SEARCH  STACK .  TEMP  LIST  ) ; 

STKOFL I  STS. PUSH (SCOPE  STACK,  TEMPLIST) ; 
end  loop; 

LASTFOUNO  :=  TEMP  POINIER; 
return  ( lEMP  POI N IE R . SYMBOL ) ; 
end  if; 
end  loop; 

while  (not  STK  OF  LISTS. EMPTY(SEARCH  STACK))  loop 
SIK  OF  _LISrS.POP(SEARCH  SIACK.  lEMPLIST); 
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STK_OF_LISTS.PUSH(SCOPE_STACK,  TEMP_LIST): 
end  loop; 

LASTFOUNO  ; =  null; 
return  (null); 
end  if; 
end  FIN0_KEY; 

function  FINO_LOCAL_KEY( KEY  :  in  string)  return  SYM_TAB_ACCESS  is 
--  post  -  If  the  symbol  table  contains  an  entry  whose  key  value  is  KEY, 
then  that  entry  is  the  current  entry  and  FIND_KEY  returns  a 
pointer  to  that  symbol  table  record,  else  FIND_KEY  returns 
a  null  pointer  and  the  current  entry  is  undefined.  NOTE  - 
the  symbol  table  IS  case  sensitive  in  it's  comparison  of  keys  and 
the  search  is  local  in  scope  according  to  ADA  visibility  rules. 
TEMPPOINTER  ;  LISTNOOEPOINTER ; 
begin 

SYMBOL_LIST.ASSIGN(CURRENT_SNL,  SEARCH_SNL); 

TEMPPOINTER  ;=  SNL_SEARCH( KEY ) ; 
if  (TEMP_POINTER  /=  null)  then 

SYM80L_LIST . ASSIGN( SEARCHSNL ,  CURRENT_SNL ) ; 

LAST_F0UN0  :=  TEMP_P0INTER ; 
return  ( TEMPPOINTER . SYMBOL ) ; 
el  se 

LAST_FOUND  null; 
return  (null); 
end  if; 

end  fIND_LOCAL_KEY; 

function  FINO_SUBPROGRAM_ENO  return  SYM_TAB_ACC£SS  is 
■■  post  -  A  search  is  conducted  to  find  the  parent  enclosing  subprogram 
of  the  parse.  A  pointer  to  the  label  "END"  for  this  parent 
enclosing  subprogram  is  returned.  This  function  is  used  to 
provide  the  operand  for  a  "return"  statement.  The  current  entry 
IS  the  end  label  corresponding  to  the  enclosing  subprogram  of  the 
parse. 

--  exceptions  raised  -  REFEREN''E_ERROR  if  no  enclosing  subprogram  can  be 
found  or  if  a  label  "END"  can  not  be  found  for 
an  enclosing  subprogram. 

PARENT  ;  LISTNOOEPOINTER ; 

TEMP  LIST  :  SYMBOLL I  ST . L I  ST ; 

SEARCHSTACK  :  STKOF  LISTS. STACK; 

SUCCESS  :  boolean; 
begin 

STK_OF_LlSTS.CREATE(SEARCH_STACK,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOLTABLEOVERFLOW; 
end  if; 

SVMBOL  L I S T . ASSIGN( CURRE N T  SNL .  SE ARCH  SNL ) ; 
if  (not  STK_0F_LISTS.EMPTY(SC0PE_STACK))  then 
STK  OF  I  ISTS.POP(SCOPE  STACK,  TEMP  LIC:,; 

STK  OF  LISTS.PUSM( SEARCH  STACK,  TEMPLIST ) ; 
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SYMBOL_LIST  .  ASSIGN(  TEMP_HST  ,  SEARCH_SNL) ; 

SYMBOL_LIST.RE  FRI EVE ( SEARCH  SNL ,  PARENT) ; 

while  {(PARENT. SYMBOL. TAG_TYPE  /-  FUNCT ION_OECLARATION_TAG )  anj  then 
(PARENT. SYMBOL. TAG_TYPE  /-  PROCEQUR£_OECLARATION_TAG ) )  loop 
if  (STK_0F_LISTS.EMPTY(SC0PE_STACK))  then 
raise  REFERENCEERROR; 
end  if; 

STK_0F_LISTS . POP( SCOPESTACK ,  TEMPLIST ) ; 

STK_0F_LISTS . PUSH( SEARCH_STACK ,  TEMPLIST ) ; 

SYMBOL_LIST . ASSIGN( TEMPLIST ,  SEARCHSNL ) ; 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL,  PARENT); 
end  loop; 

while  (not  STK_OF_LISTS.EMPTY(SEARCH_STArK))  loop 
STK_OF_LISTS . POP( SEARCHSTACK ,  TEMP_LIST) ; 
STK_OF_LISTS.PUSH(SCOPE_STACK,  TEMP_LIST); 
end  loop; 

SYMBOL_LIST.ASSIGN(PARENT.SUB_LIST,  SEARCHSNL); 

PARENT  :=  SNL_SEARCH{ "ENO" ) ; 
if  (PARENT  I-  null)  then 
LAST_FOUNO  :=  PARENT; 
return  ( PARENT . SYMBOL ) ; 
else 

raise  REFERENCEERROR ; 
end  if; 
else 

raise  REFERENCE_ERROR; 
end  if; 

end  FINO_SU6PROGRAM_£ND; 

function  F IN0_L00P_£N0  return  SYMTABACCESS  is 

--  post  -  A  search  is  conducted  to  find  the  enclosing  loop 

of  the  parse.  A  pointer  to  the  label  "ENO”  for  this 
enclosing  loop  is  returned.  This  function  is  used  to 
provide  the  operand  for  an  "exit"  statement.  The  current  entry 
is  the  end  label  corresponding  to  the  enclosing  loop  of  the 
parse. 

--  exceptions  raised  -  REF ERENCEERROR  if  no  enclosing  loop  can  be 

found  or  if  a  label  "ENO"  can  not  be  found  for 
an  enclosing  loop. 

PARENT  :  L I ST_N0DE_P0I NTER ; 

TEMP  LIST  :  SYMBOL_L 1ST . L I  ST ; 

SEARCH  STACK  ;  STK  OF _L I  STS . S 1 ACK ; 

SUCCESS  :  boolean; 
beg  i  n 

STK  OF_LISTS.CREATE(SEARCH  STACK,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOLTABLE  OVERFIOW: 
end  if; 

SYMBOLL 1ST . ASSIGN(CUHRtNr_SNL ,  SEARCH_SNL ) ; 

If  (not  STK  OF  LISTS. EMPTY(SCOPE  STACK))  then 
SIK  Of  I ISIS.POP(SCOPf  SIACK,  TEMP  LIST); 
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STK_0F_LISTS.PUSH(S£ARCH_STACK,  TEMP_LIST); 

SYMB0L_LIST .ASSIGN( TEMPLIST.  SEARCH_SNL): 
SYMBOL_LIST.RETRIEVE(SEARCH_SNL,  PARENT): 
while  {PARENT. SYMBOL. TAG_TYPE  /=  LOOP_TAG)  loop 
if  (STK_OF_LISTS.£MPTY(SCOPE_SrACX))  then 
raise  REFER£NCE_ERROR: 
end  1  f  ; 

STK_OF_LISTS.POP(SCOPE_STACK,  TEMP_LIST); 

STK_OF_LI STS . PUSH( SEARCHSTACK .  TEMP^L 1ST ) ; 
SYMBOL_LIST.ASSIGN(TEMP_LISI,  SEARCH_SNL); 

SYMBOL_LIST. RETRIEVE (SEARCH_SNL.  PARENT); 
end  loop; 

while  (not  STK_OF_LISTS. EMPT¥{ SEARCH_STACK ) )  loop 
STK_OF_LISTS.PQP{SEARCH_STACK.  TEMP^LIST); 
3TK_0f_LlSTS.PUSH{SC0PE_STACK,  T£MP_LIST); 
end  loop; 

SYMBOL  LIST.ASSIGN(PARENT.SUB_LIST.  SEARCHSNL); 

PARENT  :=  SNL_SEARCHrENO"): 
if  (PARENT  /=  null)  then 
LAST_FOUND  :=  PARENT; 
return  ( PARENT . SYMBOL ) ; 
else 

raise  REFERENC£_ERROR; 
end  if; 
else 

raise  REFERENCE_ERROR: 
end  if; 

end  FINO_LOOP_£NO; 

function  F I NO_TASK_£ND  return  SYM_TAB_ACCESS  iS 

'•  post  -  A  search  is  conducted  to  find  the  enclosing  task 

of  the  parse.  A  pointer  to  the  label  "END"  for  this 
enclosing  task  is  returned.  The  current  entry 
is  the  end  label  corresponding  to  the  enclosing  task  of  the 
parse. 

--  exceptions  raised  -  REFERENCE^ERROR  if  no  enclosing  task  can  be 

found  or  if  a  label  "END"  can  not  be  found  for 
an  enclosing  task. 

PARENT  :  LlST_NOD£ _POINTeR ; 

TEMP_LIST  :  SVMB0L_L I  ST . L I  ST ; 

SEARCH_STACK  ;  STKOFLISTS. STACK; 

SUCCESS  :  boolean; 
beg  1  n 

STKOFL I  STS. CREATE (SEARCHSTACK.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMBOL_TABL E  OVERF LOW; 
end  i  f ; 

SYMBOt  1ST. ASSIGN(CURRENr_SNL .  SEARCH_SNL ) ; 
if  (not  STKOF_LISTS.EMPTY(SCOPE  STACK))  then 
SFKOf  LISTS. POP(SCaPE_STACK,  TEMP  LIST); 

STKOF  LlSfS,PUSH(Sf ARCH  STACK.  IFMP  LIST); 
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SYMBOL_LIST  .  ASS1GN(  TEMP_LIST  ,  SE A(tCH_SNL ) ; 
SYMBOL_LIST.RETRIEV£(SEARCH_SNL.  PARENT); 

•  tiile  (PARENT.  SYMBOL.  TAG_TYPE  /=  TASK_OECLARATION_TAG )  loop 
if  (STK_OF_LISTS.EMPTY(SCOP£_STACK))  then 
raise  REFEHENCE_EHROR : 
end  if; 

STK_0F_LISTS.P0P(SC0PE_STACK.  TEMP_LIST); 
STK_OF_LISTS.PUSH(SEARCH_STACK.  TEMPLIST); 

SYMBOLLIST .ASSIGN) TEMPLIST ,  SEARCHSNL) ; 
SYMBOL_LlST.RETRIEVE(S£ARCH_SNL,  PARENT); 
end  loop; 

»hi1e  (not  STK_Of_LISTS.EMPTY(S£ARCH_STACK))  loop 
STKOF  LISTS. POP(S£ARCH_STACK.  TEMPLIST); 

STK_Of _LISTS . PUSH) SCOPE_STACK .  TEMPL 1ST ) ; 
end  loop; 

SYMBOL_L I  ST . ASSIGN) PARENT . SUB  L 1  ST .  SEARCH  SNL ) ; 

PARENT  ; -  SNL_SEARCH( "END" ) ; 
if  (PARENT  /--  null  )  then 
LAST_FOUND  ;=  PARENT; 
return  ( PARENT . SYMBOL ) ; 
else 

raise  REFER£NCE_ERROR; 
end  if; 
else 

raise  REF ERENCE_£RROR ; 
end  if; 

end  F IN0_TASK_£N0; 

procedure  UPOATE_SYM_rA8(LOCATION  :  in  natural)  is 
--  pre  -  The  current  entry  is  defined. 

-■  post  -  The  current  entry's  location  is  changed  to  LOCATION. 

TEMPPOINTER  :  LIST_NODE_POINTER; 

begin 

SYMBOL_LIST.RETRIEVE(SEARCH_SNL,  rEMP_POINTER ) ; 

TEMPPOINTER. SYMBOL. LOCATION  :=  LOCATION; 

5YMB0L_LI ST. UPDATE) SEARCH_SNL,  TEMPPOINTER) ; 
end  UPDATE_SYM_TAB; 

function  SEL£CT_COMPONENT(KEY  :  in  string)  return  SYM_TAB_ACCESS  is 
--  pre  -  FIND_KEY  or  SELECTCOMPONENT  returns  a  non-null  value. 

--  post  -  SELECTCOMPONENT  provides  visibility  to  the  ne»t  static  nesting 
level  below  the  current  entry. 

If  the  symbol  table  contains  an  entry  whose  key  value  is  KEY, 
then  that  entry  is  the  current  entry  and  FINDKEY  returns  a 
pointer  to  that  symbol  table  record,  else  FINDKEY  returns 
a  null  pointer  and  the  current  entry  is  undefined,  NOTE  - 
The  symbol  table  IS  case  sensitive  in  it’s  coir  arison  of  keys. 
TEMP  POINTER  :  LIST  NODE  POINTER; 
beg  i  n 

ENTERSEARCHSCOPE ; 

TEMP  POINTER  :  =  SNL  StARCH(KEY): 
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if  { TEMP_POINTER  =  null)  then 
LAST_FOUND  :=  null; 
return  (null); 
e  1  se 

LAST_FOUNO  ; =  TEMPPOINTER ; 
return  ( TEMP_POINrER . SYMBOL ) ; 
end  if; 

end  SELECTCOMPONENT; 

function  RETRIEVE_SYM  return  SYM_TAB_ACCESS  is 

--  post  -  RETRIEVE_SYM  returns  a  pointer  to  the  current  entry  or  null  if 
the  current  entry  is  undefined. 

TEMPPOINTER  ;  L I STNODEPOINTER ; 
begin 

if  (LAST_FOUND  /=  null)  then 
return  ( LAST_FOUNO . SYMBOL ) ; 
else 

return  (null); 
end  if; 

end  RETRIEVE_SYM; 

procedure  SAVECURRENTENTRY  is 

--  pre  -  The  current  entry  is  defined; 

--  post  -  The  current  entry  is  saved  in  a  last  in  first  out  data  structure, 
begin 

SYMBOL_H  ST  .  SAVE_L  [  ST(  SE  ARCH  SNL  ) ; 
end  SAVE_CUfiRENT_ENTRY; 

procedure  RESTORE_CURRENT_ENTRY  is 
--  pre  -  A  current  entry  was  saved: 

--  post  -  The  last  current  entry  saved  is  the  current  entry, 
begin 

SYMB0L_LIST.REST0RE_LIST(SEARCH_SNL); 

SYMBOL_LISI .RETRIEVE(S£ARCH_SNL.  LASTFOUNO); 
end  R£STORE_CURRENT  ENTRY; 

procedure  PRINT_SYM60L_TABLE  is 

--  post  -  Useful  as  a  debugging  tool.  PRINTSYMBOLTABLE  prints  a  dump  of 
every  symbol  table  entry,  including  attribute  and  location 
information,  to  the  standard  output  device.  The  current  entry  is 
undefined. 

TEMPPOINTER  ;  LI STNODE _P01 N I ER ; 

SEARCHSTACK  :  STK_0F_L I  STS . S TACK ; 

TEMP  LIST  ;  SYMBOL  L I  ST . L I  ST ; 

SUCCESS  ;  boolean; 

procedure  PRINT_RECORD( SP  :  in  ?YM  1AB_ACCESS)  is 
use  TEXTIO; 
beg  1  n 

new_ line; 

for  INDEX  in  1..SP.NAME  1 ENGTH  loop 
pul(SP.NAME( INDEX) ); 
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end  loop; 
set_col ( 30) ; 

put ( SYMBOLTAG ' IMAGE ( SP . TAG_TYPE ) ) ; 
set_col(60); 

put_l ine( natural ' IMAGE( SP . LOCATION) ) ; 
end  PRINTRECORO; 
begin 

STK_OF_LISTS.CREATE(SEARCH_STACK.  SUCCESS); 
if  (not  SUCCESS)  then 

raise  SYMB0L_TABLE_0VERFL0U; 
end  if; 

if  (not  SYMBOL_LIST.EMPTY(SYM_TAB))  then 
SyMBOL_LIST . FIND_F IRST( SYMTAB) : 

TEMP_LIST  :=  SYMTAB; 
loop 

while  (not  SYMBOL_LIST . EMPTY( TEMP_LIST ) )  loop 
STK_OF_LISTS . PUSH( SEARCH_STACK .  TEMP_L 1ST ) ; 
SYMBOL_LIST.RETRIEVE(TEMP_LIST,  TEMPPOINTER ) ; 
TEMPLIST  :=  TEMPPOI NTER . SUBLIST ; 
if  (not  SYMBOL_LIST.EMPTY(TEMP_LIST))  then 
SYMBOL_LIST.FINO_FIRST(TEMP_LIST); 
end  if; 
end  loop; 

STK_OF_LISTS . POP( SEARCH_STACK .  TEMP_LIST) ; 
SYMBOL_LISI.RETRIEV£(TEMP_LIST.  TEMP_POINT£R) ; 
PRINT_RECORD(TEMP_POINTER. SYMBOL); 
if  (not  SYMBOL_LIST.LAST(T£MP_LIST))  then 
SYMBOL_LIST.FIND_N£XT(TEMP_LIST); 
else 

while  ((not  STKOf _LISTS. £MPTY( SEARCH_STACK ) )  and  then 
(SYMB0L_LIST.LAST( TEMP_LIST)))  loop 

STK_OF_LISTS,POP(SEARCH_STACK.  TEMPLIST); 
SYM80L_LIST .RETRIEVE (TEMP_LIST.  TEMP_POINTER) ; 
PRINT_R£CORO( TEMP_POINTER. SYMBOL) ; 
end  loop; 

exit  when  ( ( STKOFL ISTS. EMPTY(SEARCH_STACK ) )  and  then 
( SYMB0L_L 1ST . LAST( TEMPL 1ST ) ) ) ; 

SYMBOLLIST ,FIN0_NEXT( TEMPLIST); 
end  if; 
end  loop; 
end  if; 

LASTFOUND  : =  null; 
end  PRINT_SYMBOL_TABLE ; 


beg  in 

IN1TIALIZE_SYM_TAB; 
end  SYMBOL_TABLE ; 
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APPENDIX  K 


”ADAF  LOW”  PROGRAM  LISTING  •  CODE  BLOCKER 


TITLE; 

ADAFLOW 

MODULE  NAME : 

PACKAGE  C0DE_BL0CKER 

-- 

FILE  NAME; 

BLOCKER. AOS 

DATE  CREATED: 

31  MAR  38 

-- 

LAST  MODIFIED: 

28  APR  38 

-- 

AUTHOR(S) : 

LT  ALBERT  J.  GRECCO,  USN 

-- 

DESCRIPTION: 

This  package  defines  the  interface  to  the 
CODE  BLOCKER  module. 

-- 

with  TOKEN_SCANNER;  --  only  for  visibility  of  type  SOURCE_RECORD 


package  C0DE_BL0CKER  is 


COO£_8LOCK£R_UNDERFLOW  ;  exception; 
C0D£_BL0CKER_0V£RFL0W  :  exception; 
UNMATCHEO_CODE_BLOCKS  :  exception; 


procedure  £NTER_C00E_BL0Ck( SOURCE  :  >n  TOKENSCANNER , SOURCE_R£CORD ; 

LABEL  :  in  string); 

--  post  -  A  unique  code  block  number,  starting  with  the  number  1  and 
continuing  sequentially,  is  generated  and  associated  with 
the  new  code  block.  The  current  code  block  number  is  the 
new  code  block  number.  The  statement  count  is  set  to  zero 


procedure  INCREMENTSTATEMENTCOUNT ; 

--  pre  -  A  code  block  has  been  entered. 

--  post  -  Used  to  count  the  number  of  statements  in  a  code 

block.  Initially  zero,  INCREMENT  STATEMENTCOUNT  increases 
the  count  of  statements  encountered  in  the  current 
code  block  by  I . 

--  exceptions  raised  -  UNMATCHED_COOE_BLOC1CS  if  a  code  block  has  not  been 
entered . 


procedure  DELETECODEBLOCKENTER; 

--  pre  -  A  code  block  has  been  entered. 

-  post  The  most  recently  entered  code  block  is  deleted  and  the  state 
of  the  code  blocker  is  restored  to  the  stale  just  prior  to  the 
erroneous  code  block  entry. 

'  exceptions  raised  -  UNMA ICHED  CODE  BLOCKS  if  a  code  block  has  not  been 
entered. 
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function  IS_COOE_BLOCK_£NTERED  return  boolean; 

--  pre  -  If  a  code  block  has  been  entered  and  not  yet  exited, 

IS_COOE_8LOCK_ENTEREO  returns  true,  else  returns  false. 

procedure  EXIT_CODE_BLOCK(SOURCE  :  in  TOK£N_SCANNER . SOURCERECORO ) ; 

--  pre  -  A  code  block  has  been  entered. 

--  post  -  The  most  recently  entered  code  block  is  added  to  a  list  of 

exited  code  blocks.  The  next  most  recently  entered  code  block, 
if  it  exists,  becomes  the  current  code  block. 

--  exceptions  raised  -  UNMATCHEO_COOE_BLOCKS  if  a  code  block  has  not  been 
entered. 

procedure  REACTIVATE_CODE_BLOCK(CODE_BLOCk_NUMBER  :  in  positive); 

--  pre  -  The  code  block  number  exists  in  the  list  of  exited  code  blocks. 

--  post  -  The  code  block  is  removed  from  the  list  of  exited  code  blocks  and 
made  the  current  code  block. 

--  exceptions  raised  -  UNMATCHED_COOE_BLOCKS  if  a  code  block  does  not  exist 
in  the  list  of  exited  code  blocks  with  the  named 
CODE_BLOCK_NUMBER. 

CODE_BLOCK£R_UNO£RFLOW  if  the  block  list  is  clear. 

function  CURRENT_CODE_BLOCK_NUMBER  return  positive; 

--  pre  -  A  code  block  has  been  entered  and  not  yet  exited. 

--  post  -  CURRENT_C00E_8L0CK_NUMBER  returns  the  number  of  the  current, 
code  block  that  has  most  recently  been  entered. 

--  exceptions  raised  -  COOE_BLOCKER_UMDERFLOW  if  the  code  blocker  is 
not  Currently  in  a  code  block. 

function  CURR£NT_STATEMENT_COUNT  return  natural; 

--  pre  -  A  code  block  has  been  entered. 

--  post  -  CURRENT_STATEMENT_COUNT  returns  the  count  of 

statements  encountered  in  the  current  code  block. 

--  exceptions  raised  -  UNMATCHEO_COOE_BLOCKS  if  a  code  block  has  not  been 
entered. 

procedure  CLEAR_CODE_BLOCKER ; 

--  post  -  Clears  the  code  blocker  of  all  code  blocks  that  have  been  entered 
and  of  all  code  blocks  in  the  list  of  exited  code  blocks.  The 
current  code  block  number  is  undefined.  The  next  code  block 
number  to  be  generated  is  1. 

function  IS_COOE_BLOCK_LIST_CLEAR  return  boolean; 

--  post  -  If  no  code  blocks  have  been  entered  and  exited  then 

IS_COOE_BLOCK_LIST_CLEAR  returns  true,  else  returns  false. 

function  IS_LAST_CODE_BLOCk  return  boolean; 

--  pre  -  The  code  block  list  is  not  clear. 

--  post  -  If  there  are  no  other  blocks  of  code  in  the  list  of  code  blocks. 

IS_LAST_COOE_BLOCI(  returns  true,  else  IS_LAST_COOE_BLOCK  returns 
false. 

-  exceptions  raised  -  COOEBLOCKER  UNOERFLOW  if  the  block  list  is  clear. 
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procedure  FINDFIRSTCODEBLOCK ; 

--  pre  -  The  code  block  list  is  not  clear  and  no  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  Rewinds  the  code  block  nst  to  the  first  block.  The  current  block 
in  the  code  block  list  is  the  first  block  in  the  code  block  list. 
--  exceptions  raised  -  COOEBLOCKERUNOERFLOW  if  the  block  list  is  clear. 

UNMArCHED_COO£_8LOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

procedure  f IND_MEXT_CQ0£_8L0Ck : 

--  pre  -  The  code  block  list  is  not  at  the  last  block  and  is  not  clear. 

No  code  blocks  have  been  entered  and  not  yet  exited. 

--  post  -  The  code  blocker  is  advanced  to  the  next  block.  The  current  block 
in  the  code  block  list  is  the  next  block  in  the  code  block  list. 

--  exceptions  raised  -  COO£_0LOCKER_UNOEflFLOW  if  the  block  list  is  clear. 

COOEBLQCKOVERFLOW  if  at  the  last  block  in  the  list. 
UNMATCH£D_C00E_8L0CKS  if  a  block  has  been  entered 
and  not  yet  exited. 

function  REA0_C0D£_BL0CK_NUM8ER  return  positive; 

--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  READ_C00£_BL0CK_NUMBER  returns  the  code  block  number  of  the 
current  code  block  in  the  code  block  list. 

--  exceptions  raised  -  COOE_BLOCK£R_UMO£RfLOU  if  the  block  list  is  clear. 

UNMATCF1ED_C00E_BL0CKS  if  a  block  has  been  entered 
and  not  yet  exited. 

function  REAO_COD£_0LOCk_STATEMENT_COUNT  return  natural; 

--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  READ_COOE_8LOCK_STATEMENT_COUNT  returns  the  number  of 

statements  recorded  as  encountered  in  the  current  code  block 
in  the  code  block  list. 

--  exceptions  raised  -  CODE_BLOCKER_UND£RFLOW  if  the  block  list  is  clear 
UNMATCHEO_CODE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

function  R£A0_C00E_BL0CK_START  return  TOKENSCANNER . SOURCE_RECORD; 
pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  REAO_COOE_BLOCK_START  returns  the  record  of  origin  of  the 

current  code  block  in  the  code  block  list  as  it  relates  to  the 
source  code. 

--  exceptions  raised  -  COOEBLOCKERUNOERFLOW  if  the  block  list  is  clear. 

UNMATCHEO_COOE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

function  READCOOEBLOCKSTOP  return  TOKENSCANNER . S0URCE_REC0R0; 

--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exiled. 
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--  post  -  READ_C0DE_BL0CK_ST0P  returns  the  record  of  completion  of  the 

current  code  block  in  the  code  block  list  as  it  relates  to  the 
source  code. 

--  exceptions  raised  -  CODE_BLOCKER_UND£Rf LOW  if  the  code  blocker  is  clear. 

UNMATCHEOCODEBLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

function  R£AD_C00E_8L0CK_LABEL  return  string; 

--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  REAO_COOE_BLOCK_LAB£L  returns  the  label  entered  when  the 
current  code  block  in  the  code  block  list  was  entered. 

--  exceptions  raised  -  COOE_BLOCKER_UNOERFLOW  if  the  code  blocker  is  clear. 

UNMATCHED_CODE_6LOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

end  CODE_BLOCKER; 
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TITLE: 

ADA FLOW 

MODULE  NAME; 

PACKAGE  C00E_BL0CKER 

-- 

FILE  NAME: 

BLOCKER. AOB 

DATE  CREATED; 

31  MAR  88 

-- 

LAST  MODIFIED 

28  APR  88 

-- 

AUTHOR(S) : 

LT  ALBERT  J,  GRECCO,  USM 

— 

DESCRIPTION; 

This  package  implements  the  interface  to  the 
C00E_8L0CKER  module. 

-- 

with  ORDERED_GENERIC_LIST, 

GENERIC_STACK. 

UNCHECKED_D£ALLOCATION. 

TOKEN_SCANNER;  --  only  for  visibility  of  type  SOURCE_RECORO 
package  body  COOE_BLOCKER  is 


type  C00E_BL0CK_REC0RD  is 


record 

BLOCK_NUMBER 

STATEMeNT_COUNT 

START 

STOP 

LABEL 

LABEL_LENGTH 
end  record: 


positive; 
natural  :=  0; 

T0((EN_SCANNER .  S0URC£_R£C0RD ; 
T0KEN_SCANNER . SOURCE.RECORO ; 
String(  1 .  .  TOICEN_SCANNER .  LINESIZE  ) 
natural ; 


(others  => 


type  C00E_8L0Ck_P0INTER  is  access  C00E_BL0CK_REC0RD; 

NEXTBLOCKNUMBER  :  positive  t; 

CURRENT_BLOCK_NUMBER  :  positive; 


package  BLOCK_LIST  is  new  ORDERED_GEN£RIC_LIST(CODE_BLOCK_POINTER) : 
package  BLOCKSTACX  is  new  GENERIC_STACK{COOE_BLOCX_POINTER) ; 
procedure  FREE_C00E_8L0CK  is  new 

UNCHECKED_DEALLOCATION(COOE  BLOCK_RECORD.  C00E_BL0CK_P0INTER ) 

BL  :  BLOCKLIST.LIST; 

BS  :  BLOCK_STACK. STACK; 

procedure  I NI T I ALl ZE_COO£_Bl OCKER  is 

SUCCESS  ;  boolean; 

begin 

BLOCK_LIST .CREATt(BL ,  SUCCESS): 
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if  (not  SUCCESS)  then 

raise  C0DE_BL0CKER_0V£Rf LOW; 
end  if; 

BLOCK_STACK.CR£ATE(BS,  SUCCESS); 
if  (not  SUCCESS)  then 

raise  C0D£_BL0CKER_0VERFL0W; 
end  if; 

NEXT_BLOCK_NUMBER  ; =  1 ; 
end  INITIALIZE_COOE_BLOCKER; 

procedure  ENTER_C0DE_8L0CK( SOURCE  ;  in  TOKEM_SCANNER.SOURCE_RECORD; 

LABEL  :  in  string)  is 

--  post  -  A  unique  code  block  number,  starting  with  the  number  1  and 
continuing  sequentially,  is  generated  and  associated  with 
the  new  code  block.  The  current  code  block  number  is  the 
new  code  block  number. 

TEMP  POINTER  ;  COOE_BLOCk_POINTER; 
begin 

TEMPPOINTER  ;=  new  COOEBLOCKRECORO; 

TEMP_POINTER.8LOCK_NUMBER  ;=  NEXT_BLOCK_MUMB£R ; 

CURRENT_BL0CX_NUM8ER  :=  NEXTBLOCKNUMBER; 

NEXT_BLOCX_NUMBEfi  ;=  NEXT_8L0CX_NUMBlR  +  1; 

TEMP_POINTER.STATEMENT_COUNT  ;=  0; 

TEMP_POINTER. START  ;=  SOURCE; 

TEMP_POINTER. LABEL  ;*  (others  =>  '  '); 

TEMP_POIMTER.LAB£L( 1 . .LABEL'LAST)  ;=  LABEL; 

TEMP_POINTER.LAB£L_LENGTH  ;=  LABEL • LENGTH; 

8L0CK_STACK . PUSH( 8S .  T£MP_POrNT£R ) ; 
end  ENTER_C00£..BL0Ck; 

procedure  INCRtMENT_STATEMENT_COUNT  is 
--  pre  -  A  code  block  has  been  entered. 

post  -  Used  to  count  the  number  of  statements  in  a  code 

block.  Initially  zero,  INCREMENT  _STATEMENT_COUNT  increases 
the  count  of  statements  encountered  in  the  current 
code  block  by  I . 

--  exceptions  raised  -  UNMATCHED_COOE_BLOCKS  if  a  code  block  has  not  been 
entered. 

TEMP  POINTER  :  COOE_BLOCX_POINTER ; 
begin 

if  (BLOCX_STACK.EMPTY(8S))  then 
raise  UNMATCHE0_C0DE_8L0CKS; 
else 

BL0CK_STACK.P0P(BS,  TEMPPOINTER) ; 

TEMPPOINTER. STATEMENT  COUNT 

natural •SUCC(TEMP  POINTER. STATEMENT  COUNT) ; 
BLOCX_STACX.PUSH(BS,  TEMP  POINTER); 
end  if; 

end  INCREMENT  STATEMENT  COUNT; 
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procedure  DELETECOOEBLOCKENTER  is 
--  pre  -  A  code  block  has  been  entered. 

--  post  -  The  most  recently  entered  code  block  is  deleted  and  the  state 
of  the  code  blocker  is  restored  to  the  state  just  prior  to  the 
erroneous  code  block  entry. 

--  exceptions  raised  -  UNMATCHEDCODEBLOCkS  if  a  code  block  has  not  been 
entered. 

TEMPPOINTER  :  COOE_BLOCK_POINTER; 
begin 

if  (BLOCK_STACK.EMPTY(BS))  then 
raise  UNMATCHED_C0DE_8L0CKS; 
else 

BLOCK_STACK.POP(BS,  TEMP_POINTER) ; 

FREE_CODE_BLOCK(TEMP_POINTER); 

NEXT_BLOCK_NUMBER  :=  NEXT_BL0CK_NUM8ER  -  1: 
if  (not  BLOCK_STACK. EMPTY (BS))  then 
8L0CK_STACX . TOP( BS .  TEMP_POI NTER ) ; 

CURRENT_BLOCK_NUMBER  TEMPPOINTER . BLOCKNUMBER ; 
end  if; 
end  if; 

end  OELETE_COOE_BLOCK_ENTER; 

function  IS_COOE_BLOCk_ENTERED  return  boolean  is 

--  pre  -  If  a  code  block  has  been  entered  and  not  yet  exited, 

IS_COOE_BLOCK_ENTERED  returns  true,  else  returns  false. 

begin 

return  (not  BLOCK_STACK.EMPTY(BS)): 
end  IS_COO£_BLOCk_ENTEREO; 

procedure  EXIT_C0DE_BL0CK( SOURCE  :  in  TOKEN_SCANNER . SOURCE_RECORD)  is 
--  pre  -  A  code  block  has  been  entered. 

post  -  The  most  recently  entered  code  block  is  added  to  a  list  of 

exited  code  blocks.  The  next  most  recently  entered  code  block, 
if  it  exists,  becomes  the  current  code  block. 

--  exceptions  raised  -  UNMATCHED_COOE_BLOCKS  if  a  code  block  has  not  been 
entered. 

TEMPPOINTER  ;  C00E_BL0CK_P0INTER; 
begin 

if  (BLOCK_STACK.EMPTY(BS))  then 
raise  UNMATCHE0_C0DE_8L0CKS ; 
else 

BLOCK_STACK.POP(BS,  TEMPPOI N TE R ) ; 

TEMPPOINTER.STOP  :=  SOURCE; 

BLOCK_LIST. INSERT(8L,  TEMPPOINTER.  TEMPPOINTER . BLOCKNUMBER ) ; 
if  (not  BLOCK_STACK.EMPTY(BS))  then 
BLOCK_STACK.TOP(BS,  TEMP_POINTER ) ; 

CURRENTBLOCKNUMBER  :=  TEMPPOINTER. BLOCK  NUMBER; 
end  if; 
end  if; 

end  EXIT  CODE  BLOCK; 
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procedure  REACTIVATE_C00e_BL0CK{C00E_8l0CK_MUMBER  .  in  positive)  is 
--  pre  The  code  block  number  exists  in  the  list  of  exited  code  blocks. 

--  post  -  The  code  block  is  removed  from  the  list  of  exited  code  blocks  and 
made  the  current  code  block. 

--  exceptions  raised  -  UNMATCHED_COOE_BLOCKS  if  a  code  block  does  not  exist 
in  the  list  of  exited  code  blocks  with  the  named 
C0DE_BL0CK_NUM8ER. 

CODEBLOCKERUNDERfLOW  if  the  block  list  is  Clear. 
TEMPPOINTER  :  COOE_BLOCK_POINTER ; 
begin 

if  (BLOCk_LIST.EMPTy(BL) )  then 
raise  CODE_BLOCKER_UND£RFLOW: 
else 

BLOCK_LIST.FINO_fIRST(BL); 

BLOCK_LIST.R£TRIEVE(BL.  TEMPPOINTER ) ; 

while  (TEMP_P0INTER.8L0CI(_MUMBER  /=  COOE_BLOCK_MUMBER)  loop 
if  (BL0CK_LIST.LAST(8L))  then 
raise  UNMATCHED  COOEBLOCKS; 
else 

BLOCK_LIST.FIND_NEXT(BL); 

6L0CK_LIST.RETRIEVE(BL.  TEMPPOINTER) ; 
end  if; 
end  loop; 

BL0CK_LIST.0ELETE(BL); 

BLOC l<_STACI(. PUSH (BS,  TEMP_POINTER) ; 

CURReNT_8L0CK_NUM8eR  ; =  C00E_8L0Ck_NUM6£R; 
end  if; 

end  REACTIVATE_C0DE_8L0CK; 

function  CURRENT_C0D£_BL0CK_NUMB£R  return  positive  is 
--  pre  -  A  code  block  has  been  entered  and  not  yet  exited. 

--  post  -  CURRENT_CODE_BLOCII_NUMBER  returns  the  number  of  the  current. 

code  block  that  has  most  recently  been  entered. 

--  exceptions  raised  -  CODE_BLOCKER_UNOERFLOW  if  the  code  blocker  is 
not  currently  in  a  code  block. 

begin 

if  (8L0CK_STACK.EMPTY(BS))  then 
raise  COOE_BLOCKER_UNDERFLOW; 
else 

return  ( CURRENT_BLOCK_NUMBER ) ; 
end  if; 

end  CURRENT_C00E_BL0CIC_NUM8ER; 

function  CURRENT_STArEMENT_COUNT  return  natural  is 
pre  -  A  code  block  has  been  entered. 

--  post  -  CURREMT_STATEMENT_COUNT  returns  the  count  of 

statements  encountered  in  the  current  code  block. 

--  exceptions  raised  -  UNMATCHEOCODE  BLOCKS  if  a  code  block  has  not  been 
entered. 

TEMP  POINTER  :  CODEBLOCKPOINTER : 
begin 
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if  (BLOCK_STACK.EMPTY(BS) )  then 
raise  UNMATCHEO_COOE_BLOCKS; 
else 

BLOCK_STACK.TOP(BS,  TEMPPOINTER) ; 
return  ( TEMP_POINTER . STATEMENTCOUNT ) ; 
end  if; 

end  CURRENT_STATEMENT_COUNT: 
procedure  CLEAR_CODE_BLOCKER  is 

--  post  -  Clears  the  code  blocker  of  all  code  blocks  that  have  been  entered 
and  of  all  code  blocks  in  the  list  of  exited  code  blocks.  The 
current  code  block  number  is  undefined.  The  next  code  block 
number  to  be  generated  is  1. 

TEMP  POINTER  :  COOE_BLOCK_POINTER: 
begin 

while  (not  8L0CK_LIST.EMPTY(8L))  loop 
BLOCK_LIST.RETRIEVE(BL.  TEMPPOINTER) ; 

FREE_COOE_BLOCK(TEMP_POINTER) ; 

BLOCK_LIST.OELETE(BL) ; 
end  loop; 

while  (not  BLOCK_STACK.EMPTY(BS))  loop 
BLOCK_STACK.POP(BS,  TEMPPOINTER ) ; 

FREE_COOE_BLOCK(TEMP_POINTER): 
end  loop; 

NEXT_BLOCIC_NUMBER  ;=  1; 
end  CLEAR_C00£_8L0CKER; 

function  IS_C00E_6L0CK_LIST_CLEAR  return  boolean  is 
--  post  -  If  no  code  blocks  have  been  both  entered  and  exited  then 
IS_CODE_BLOCK_LIST_CLEAR  returns  true,  else  returns  false. 

begin 

return  ( BLOCK_LIST . EMPTY( BE ) ) ; 
end  IS_COOE_BLOCK_LIST_CLEAR; 

function  IS_LAST_CODE_BLOCK  return  boolean  is 
--  pre  -  The  code  block  list  is  not  clear. 

--  post  -  If  there  are  no  other  blocks  of  code  in  the  list  of  code  blocks. 

IS_LAST_CODE_BLOCK  returns  true,  else  IS_LAST_CODE_BLOCK  returns 
false. 

--  exceptions  raised  -  CODEBLOCKERJJNOERF LOW  if  the  block  list  is  clear, 
begin 

if  (BLOCK_LIST.EMPTY(BL))  then 
raise  C00E_BL0CKER_UN0ERFL0W; 
else 

return  (BLOCKLIST . LAST(BL ) ) ; 
end  if; 

end  IS_LAST_CODE_BLOCK; 
procedure  FINDFIRSTCODEBLOCK  is 

--  pre  -  The  code  block  list  is  not  clear  and  no  code  blocks  have  been 
entered  and  not  yet  exited. 
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--  post  -  Rewinds  the  code  block  list  to  the  first  block.  The  current  block 
in  the  code  block  list  is  the  first  block  in  the  code  block  list. 
--  exceptions  raised  -  C0DE_BL0CKER_UN0£Hf LOW  if  the  block  list  is  clear. 

UNMATCHED_COOE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

begin 

if  (BLOCK_LIST.EMPTY(BL))  then 
raise  COOEBLOCKERUNDERFLOW; 
elsif  (not  BLOCK_STACI(.EMPTY(BS))  then 
raise  UNMATCHED_CODE_BLOCKS; 
else 

BLOCK_LIST.FIND_FIRST(BL); 
end  if; 

end  FIND_FIRST_C00£_8L0CK; 
procedure  FIND_NEXT_C00£_BL0CK  is 

--  pre  -  The  code  block  list  is  not  at  the  last  block  and  is  not  clear. 

No  code  blocks  have  been  entered  and  not  yet  exited. 

--  post  -  The  code  blocker  is  advanced  to  the  next  block.  The  current  block 
in  the  code  block  list  is  the  next  block  in  the  code  block  list. 

--  exceptions  raised  -  CQOE_8LQCKER_UNOERFLOW  if  the  block  list  is  clear. 

COOE_BLOCK_OVERFlOW  if  at  the  last  block  in  the  list. 
UNMATCHED_COOE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

begin 

if  (BLOCk_LIST.EMPTY(BL))  then 
raise  COOE_BLOCKER_UNDERFLOW: 
elsif  (8L0CK_LIST.LAST(BL))  then 
raise  COOE_8LOCKER_OVERf LOW; 
elsif  (not  BLOCK_STACK.EMPTY(BS))  then 
raise  UNMATCHED_COOE_BLOCKS; 
else 

BL0CK_L[ST.FIN0_NEXT(8L); 
end  if; 

end  FINONEXTCOOEBLOCK; 

function  READCOOEBLOCKNUMBER  return  positive  is 
--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  REAOCODEBLOCXNUMBER  returns  the  code  block  number  of  the 
current  code  block  in  the  code  block  list. 

--  exceptions  raised  -  COOEBLOCXERUNOERFLOW  if  the  block  list  is  clear. 

UNMATCHEOCODE  BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

TEMP  POINTER  :  COOEBLOCKPOINTER ; 
beg  in 

if  (BLOCK_LIST.EMPTY{BL))  then 
raise  CODEBLOCKERUNDERFLOW; 
elsif  (not  BLOCX_STACK.EMPTY(BS))  then 
raise  UNMATCHED  CODE  BLOCKS; 
e  I  se 
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BL0CK_LIST.RETRIEVE{BL,  TEMP_POINTER) ; 
return  { TEMP_POrNTER . BLOCK_NUMB£R ) ; 
end  if; 

end  READ_CODE_BLOCK_NUMBER; 

function  READ_CODE_BLOCK_STATEMENT_COUNT  return  natural  is 
--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  REAO_COOE_BLOCK_STATEMENT_COUNT  returns  the  number  of 

statements  recorded  as  encountered  in  the  current  code  block 
in  the  code  block  list. 

--  exceptions  raised  -  CODE  BLOCKERUNOERFLOW  if  the  block  list  is  clear 
UNMATCHED_COOE_BLOCKS  If  a  block  has  been  entered 
and  not  yet  exited. 

TEMP_POINTER  ;  CODE_BLOCK_POINTER: 
beg  i  n 

if  (BL0CK_LIST.EMPTY(BL) )  then 
raise  CODE_BLOCkER_UNDERFLOW ; 
elsif  (not  BL0CK_SrACK.EMPrY(6S))  then 
raise  UNMATCH£0_C0DE_BL0CKS; 

else 

BLOCK_LIST.RETRIEVE(BL.  TEMP_POINTER) ; 
return  ( TEMP_POINTER . STATEMENT_COUNT ) ; 
end  If; 

end  REAO,CODe_8LOCK_STATEMENT_COUNT ; 

function  R£AO_COO£_BLOCK_STARr  return  TOKEN_SCANN£R . SOURC£_RECORD  Is 
pre  -  The  code  block  list  is  not  clear.  Mo  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  READ_COD6_BLOCK_START  returns  the  record  of  origin  of  the 

current  code  block  in  the  code  block  list  as  it  relates  to  the 
source  code. 

--  exceptions  raised  -  CODEBLOCKERUNOERFLOW  if  the  block  list  is  clear 
UNMATCHEO_COOE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

TEMPPOINTER  :  CODE_BLOCK_POINTER ; 
begin 

if  (BLOCK_LIST.EMPTY(BL))  then 
raise  C00E_BL0CKER_UN0ERFL0W. 
elsif  (not  BLOCK_STACK . EMPTy( BS) )  then 
raise  UNMATCHE0_C00E^BL0CKS; 
el  se 

BLOC)t_LI ST  .RETRIEVE (Bl.  TEMP  POINTER ) ; 
return  ( TEMPPOINTER . START ) ; 
end  if; 

end  REAO_CODE_BLOCK_START; 

function  READ  C0D£_BL0CK_ST0P  return  TOKENSCANNER . SOURCE  RECORD  is 
-  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  nave  been 
entered  and  not  yet  exited. 

•  post  -  READCOOEBLOCK  STOP  returns  the  record  of  completion  of  the 
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current  code  block  in  the  code  block  list  as  it  relates  to  the 
source  code. 

--  exceptions  raised  -  COOEBLOCKERUNDERFLOW  if  the  code  blocker  is  clear 
UNMATCHED  CODEBLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

TEMPPOINTER  :  C00E_8L0CK_P0INTER ; 
begin 

if  (BLOCK_LIST.EMPTY(BL))  then 
raise  CODE_BLOCKER_UNOERFLOW; 
elsif  (not  BLOCKSTACK . EMPTy(BS) )  then 
raise  UNMATCHEO_CODE_BLOCKS ; 
else 

BLOCK_LIST.RETRIEVE(BL,  TEMPPOINTER) ; 
return  ( TEMPPOINTER . STOP ) ; 
end  if; 

end  READ_COOE_BLOCK_STOP; 

function  READCOOEBLOCKLABEL  return  string  is 

--  pre  -  The  code  block  list  is  not  clear.  No  code  blocks  have  been 
entered  and  not  yet  exited. 

--  post  -  READ_CODE_BLOCK_LABEL  returns  the  label  entered  when  the 
current  code  block  in  the  code  block  list  was  entered. 

--  exceptions  raised  -  CODE_BLOCKER_UMOERFLOW  if  the  code  blocker  is  clear 
UNMATCHED_COOE_BLOCKS  if  a  block  has  been  entered 
and  not  yet  exited. 

TEMP_POINTER  :  C00£_BL0CK_P0INTER ; 
begin 

if  (BLOCK_LIST.£MPTY(BL))  then 
raise  C0D£_BL0CK£R_UN0ERFL0W; 
elsif  (not  BLOCK_STACK.EMPTY(BS))  then 
raise  UNMATCHEO_COOE_BLOCKS; 
e  1  se 

BLOCK_LIST.RETRIEVE(BL ,  TEMP_P01NTtR) ; 

return  ( T£MP_POINTER . LABEL(  I .  . TEMP  POINTER . LABtL_LEN6TH ) ) ; 
end  i f ; 

end  REAO_CODE_BLOCK_LABEL  ; 
beg  1  n 

INITIALIZECOOEBLOCKER; 
end  C00E_BL0CKER; 
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APPENDIX  G 


"ADAKLOW”  PROGRAM  LISTING  •  TOKEN  MATCHER 


TITLE: 

AOAFLOW 

““ 

-- 

MODULE  NAME; 

PACKAGE  TOKEN_MATCHER 

-- 

-- 

FILE  NAME: 

MATCH. AOS 

-- 

-- 

DATE  CREATED: 

18  FEB  88 

-- 

-- 

LAST  MODIFIED 

28  APR  88 

-- 

-- 

AUTHOR(S) ; 

LT  ALBERT  J.  GRECCO,  DSN 

-- 

-- 

DESCRIPTION: 

This  package  defines  the  interface  to  the 

-- 

-- 

module  that  identifies  each  individual 

-- 

-- 

token  and  manages  the  TOKEN_SCANNER .  The 

- 

-- 

TOKEN_MATCH£R  is  the  sole  manager  of  the 

-- 

-- 

TOK£N_SCANNER  interface  and  all  access  to 

the 

-- 

-- 

TOKEN_SCANNER  interface  is  through  T0KEN_ 

-- 

-- 

MATCHER.  This  restriction  does  not  apply 

to 

-- 

-- 

types  specified  in  the  TOKEN  SCANNER 

-- 

interface.  Types  specified  in  the  T0KEN_ 

SCANNER  interface  are  available  for  global  use.-- 


with  TOKEN_SCANNER: 
package  TOKENMATCHER  is 

The  following  token  codes  define  the  terminals  of  the  ADA  language. 


--  basic  tokens 


T0KEN_IDENTIF1ER 

constant  integer  :=  1; 

token_numeric_literal 

constant  integer  :=  2; 

TOKEN_CHARACTER_LITERAL 

constant  integer  :=  3; 

TOKEN_STRING_LITERAL 

constant  integer  ;=  4; 

reserved  word  tokens 

T0KEN_END 

constant  integer  ;=  5; 

TOKEN_BEGIN 

constant  integer  6; 

T0K£N_IF 

constant  integer  ;=  7; 

TOKEN_THEN 

constant  integer  :=  8; 

TOKEN  ELSIF 

constant  integer  ;=  9; 

TOKENJLSC 

constant  integer  10 
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TOKEN_WHILE 

TOKENLOOP 

TOKEN_CASE 

TOKEN_WHEN 

TOKEN_DECLARE 

TOKENFOR 

TOKEN_OTHERS 

TOKEN_RETURN 

TOKEN_EXIT 

TOKEN_PROC£DURE 

TOKEN_FUNCTION 

TOX£N_WITH 

TOKEN_USE 

TOKEN_PACKAGE 

TOKEN_BODY 

TOKEN_RANGE 

TOKEN_IN 

TOKEN_OUT 

TOICEN_SUBTYPE 

TOKEN_TYP£ 

TOKEN_IS 

TOKEN_NULL 

TOKEN_ACC£SS 

TOKEN_AftRAY 

TOKEN_OIGITS 

TOKEN_DELTA 

TOKEN_R£CORO_STRUCTUR£ 

T0KEN_C0NSTANT 

TOKEN_NEW 

TOKEN_EXCEPTION 

rOKEN_RENAM£S 

TOKEN_PRIVATE 

TOKEN_LIMITED 

TOKEN_TASK 

TOKEN_ENTRY 

TOKENACCEPT 

TOKEN_OELAY 

TOKEN_SELECT 

TOKEN_TERMINATE 

TOKEN_ABORT 

TOXEN_SEPARATE 

TOKEN_RAISE 

TOXEN_GENERIC 

TOKEN_AT 

TOKENREVERSE 

TOKENDO 

TOKENGOTO 

TOKENOF 

TOKEN_ALL 

TOKEN  PRAGMA 

TOKEN  AND 


constant  integer 

=  11 

constant  integer 

=  12 

constant  integer 

=  13 

constant  integer 

=  14 

constant  integer 

=  15 

constant  integer 

=  16 

constant  integer 

=  17 

constant  integer 

=  18 

constant  integer 

=  19 

constant  integer 

=  20 

constant  integer 

=  21 

constant  integer 

=  22 

constant  integer 

-  23 

constant  integer 

=  24 

constant  integer 

=  25 

constant  integer 

=  26 

constant  integer 

=  27 

constant  integer 

=  28 

constant  integer 

=  29 

constant  integer 

=  30 

constant  integer 

=  31 

constant  integer 

=  32 

constant  integer 

=  33 

constant  integer 

=  34 

constant  integer 

*  35 

constant  integer 

=  36 

constant  integer 

=  37 

constant  integer 

=  38 

constant  integer 

=  39 

constant  integer 

=  40 

constant  integer 

=  41 

constant  integer 

=  42 

constant  integer 

=  43 

constant  integer 

=  44 

constant  integer 

=  45 

constant  integer 

=  46 

constant  integer 

=  47 

constant  integer 

=  48 

constant  integer 

=  49 

constant  integer 

=  50 

constant  integer 

=  51 

constant  integer 

=  52 

constant  integer 

=  53 

constant  integer 

=  54 

constant  integer 

=  55 

constant  integer 

=  56 

constant  integer 

=  57 

constant  integer 

=  58 

constant  integer 

=  59 

constant  integer 

=  60 

constant  integer 

=  61 
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TOKEN_OR 

constant  integer 

=  62 

TOKEN_NOT 

constant  integer 

=  63 

TOK£N_XOR 

constant  integer 

=  64 

rOKEN_MOO 

constant  integer 

=  65 

TOKEN_REM 

constant  integer 

=  66 

TOK£N_ABSOLUTE 

constant  integer 

-  67 

delimiter  tokens 

TOKEN_ASTERISK 

constant  integer 

=  68 

TOKENSLASH 

constant  integer 

-  69 

TOKEN_EXPONENT 

constant  integer 

=  70 

TOKEN_PLUS 

constant  integer 

=  71 

TOKEN_MINUS 

constant  integer 

=  72 

TOK£N_AMPERSAND 

constant  integer 

=  73 

TOKEN_EQUALS 

constant  integer 

=  74 

TOKEN_NOT_E0UALS 

constant  integer 

=  75 

TOKEN_LESS_THAM 

constant  integer 

=  76 

TOKEN_LESS_THAN_E0UALS 

constant  integer 

=  77 

T0KEN_6fiEATER_THAN 

constant  integer 

=  78 

TOK£N_Gfi£ATER_IHAN_EQUALS 

constant  integer 

=  79 

TOKEN_ASSrGNMENT 

constant  integer 

=  80 

TOK£N_SEMICOLON 

constant  integer 

=  81 

T0K£N_P£RI0D 

constant  integer 

X  82 

TOK£N_LEFT_PAfiEN 

constant  integer 

=  83 

TOKEN_RIGHT_PAR£N 

constant  integer 

=  84 

T0KEN_C0L0N 

constant  integer 

=■  85 

TOK£N_COMMA 

constant  integer 

r  86 

TOKeN_APOSTROPHE 

constant  integer 

=  87 

TOKEN_RANG£_OOTS 

constant  integer 

=  88 

TOKEN_ARROW 

constant  integer 

=  89 

TOK£N_BAR 

constant  integer 

=  90 

TOK£M_BRACKETS 

constant  integer 

=  91 

TOKEN_LEFT_BRACKET 

Constant  integer 

=  92 

T0KEN_fiIGHT_8RACK£T 

constant  integer 

=  93 

procedure  SET_UP_TOKEN_MATCHER( FILE^NAME  :  string); 

--  pre  -  must  be  called  before  any  of  the  defined  interfaces  in 

TOKEN_MATCHER  are  invoked.  Any  previously  set  up  FIL£_NAME 
must  be  released  by  RELEASETOKEMSCANNER . 

--  post  -  the  lOKENMATCHER  interfaces  are  defined. 

procedure  RELEASE_TOKEN_MATCHER; 

--  pre  -  TOKENMATCHER  has  been  set  up. 

--  post  -  all  TOKENMATCHER  interfaces  are  undefined  with  the 
exception  of  SET_UP_TOKEN_MATCHER. 

TOKEN  MATCHER  may  be  set  up  for  another  FILENAME.  The 
TOKEN^MATCHER  must  be  released  prior  to  main  program 
termination. 

function  MATCH(  TOKEN  CODE  -.  in  positive)  return  boolean; 

-  pre  -  TOKEN  MATCHER  has  been  set  up. 

-  post  -  the  current  token  under  the  read  head  of  the  TOKENSCANNER 
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matches  the  TOKEN_CODE  then  MATCH  is  TRUE  and  the  read  head  of 
the  TOKEN_SCANNER  is  advanced  one  token.  Else  HATCH  is  FALSE 
and  the  read  head  of  the  TOKEN_SCANNER  does  not  advance. 

procedure  MATCHED_TOKEN( TOKEN  :  out  TOK£N_SCANNER . TOKEN_RECORD_TYPE ) ; 

--  pre  -  TOKENMATCHER  has  been  set  up  and  at  least  one  call  to  the 
function  MATCH  has  returned  TRUE. 

--  post  -  TOKEN  contains  the  token  that  caused  the  last  call  to  MATCH 
to  be  TRUE.  NOTE  -  All  identifiers  are  converted  to  upper 
case  by  the  token  matcher  and  all  reserved  words  are  converted 
to  lower  case  by  the  token  matcher  regardless  of  original  format 
in  the  source  code.  All  other  token  types  are  left  in  original 
source  code  format. 

procedure  CURRENT_TOKEN( TOKEN  :  out  TOKEN_SCANNER . TOKEN_RECORD_TYPE ) ; 

--  pre  -  TOKEN_MATCHER  has  been  set  up. 

--  post  -  TOKEN  contains  the  token  that  is  under  the  TOKEM_SCAMNER ’ s 
read  head. 

procedure  NEXT_TOKEN( TOKEN  :  out  TOKEN_SCANNER . TOKEN_RECORD_TYPE ) ; 

--  pre  -  TOKEN_MATCHER  has  been  set  up. 

--  post  -  TOKEN  contains  the  token  that  is  next  to  be  read  by  the 
TOKEN_SCANNERS  read  head. 

function  LIN£S_CHECKE0  return  positive; 

--  pre  -  TOK£N_MATCH£R  has  been  set  up. 

--  post  -  returns  the  number  of  lines  of  code  that  have  been  checked 
by  the  TOKEN_MATCHER . 

function  VALIO_COMMENTS  return  natural; 

--  pre  -  T0KEN_MATCHER  has  been  set  up. 

--  post  -  returns  the  number  of  “meaningful"  comments  seen  by  the 

TOKENMATCHER ,  A  "meaningful”  comment  is  defined  as  a  comment 
that  contains  at  least  one  letter  or  digit. 

end  T0KEN_MATCHER; 
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TITLE: 


AOAFLOW 


--  MODULE  NAME:  PACKAGE  TOKEN_MATCHER 

--  FILE  NAME:  MATCH. ADB 

--  DATE  CREATED:  18  FEB  88 

--  LAST  MODIFIED:  28  APR  88 

--  AUTHOR(S):  LT  ALBERT  J.  GRECCO.  USN 

--  DESCRIPTION:  This  package  implements  ttie  interface  to  the 
module  that  identifies  each  individual 
token  and  manages  the  TOKEN_SCANMER.  The 
TOKEN_MATCH£R  is  the  sole  manager  of  the 
TOK£N_SCANNER  interface  and  all  access  to  the 
TOKENSCANNER  interface  is  through  T0KEN_ 

MATCHER.  This  restriction  does  not  apply  to 
types  specified  in  the  TOKEN  SCANNER 
interface.  Types  specified  in  the  T0KEN_ 

SCANNER  interface  are  available  for  global  use.-- 


with  TOKEN_SCANN£R.  TEXT_I0; 

package  body  T0KEN_MATCH£R  is 

SOURCE_FIL£  :  TEXT_IO . f i le_type ; 

H0LD_T0KEN  :  TOK£N_SCANNER . TOKEN_RECORO_TYPE ; 

procedure  SET_UP_TOKEN_MATCHER( FI LE_NAME  :  string)  is 

--  pre  -  must  be  called  before  any  of  the  defined  Interfaces  in 

TOKEN_MATCHER  are  invoked.  Any  previously  set  up  F1LE_NAME 
must  be  released  by  RELEASE_TOKEN_SCANNER. 

--  post  -  the  TOKENMATCHER  interfaces  are  defined, 
begin 

TEXT_I0.3pen(S0URCE_FILE,  TEXTIO . inf  lie,  FILENAME, 

TEXTIO. reset(SOURCE_FILE); 

TOKEN_SCANNER . SE T_UP_TOKEN_SCANN£R( SOURCE  .FILE ) ; 
end  S£T_UP_TOKEN_MATCHER; 

procedure  RELEASE_TOKEN_MArCHER  is 
--  pre  -  TOKENMATCHER  has  been  set  up. 

--  post  -  all  TOKEN_MATCHER  interfaces  are  undefined  with  the 
exception  of  SETUPTOKEN  MATCHER. 

TOKENMATCHER  may  be  set  up  for  another  FILENAME,  the 
TOKEN_MATCHER  must  be  released  prior  to  main  program 
termination. 

beg  in 
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TOKEN_SCANNER . RELEASE_TOKEN_SCANNER( SOURCE_F ILE ) ; 
end  RELEASE_TOKEN_MATCHER; 

function  MATCH( T0KEN_C0DE  ;  in  positive)  return  boolean  is 
--  pre  -  TOIlEN_MATCHER  has  been  set  up. 

--  post  -  if  the  current  token  under  the  read  head  of  the  fOkENSCANNER 
matches  the  T0KEN_C00E  then  MATCH  is  true  and  the  read  head  of 
the  TOKENSCANNER  is  advanced  one  token.  Else  MATCH  is  false 
and  the  read  head  of  the  TOKEN_SCANNER  does  hot  advance, 
use  TOKEN_SCANNER.' 
subtype  BASIC_TOKENS  is 

positive  range  TOKENIDENTl FIER . . TOKEN_STRING_LI TERAL ; 
subtype  RESERVED_TOKENS  is 

positive  range  TOKENENO . . TOKEN_ABSOLUTE ; 
subtype  DELIMI TER_TOKENS  is 

positive  range  TOKEN_ASTERISK. .TOKEN_RIGHT_BRACKET; 
CURRENT_TOK£N  :  TOKEN_SCANN£R . TOK£M_RECORO_TYPE ; 

TESTTOKEN  :  TOKENSCANNER . TOKEN_RECORO_TYPE ; 

1S_SAM£  ;  boolean  ; =  FALSE; 

function  ASSIGN( TESTSTRING  :  in  string)  return 

TOKEN_SCANNER . T0K£N_REC0R0_TYP£  i s 
TEMP_TOKEN  :  TOKEN_SCANN£R . T0K£N_R£C0R0_TYPE ; 
begin 

TEMP_TOKEN.L£X£M£_SIZE  :=  TEST_STRIMG ' LENGTH ; 

TEMP_TOK£N. LEXEME  ;=  (others  =>  •  '); 

T£MP_TOKEN.LEX£ME(l. ,TEST_STRING'LAST)  ;=  TEST_STRING; 

T£MP_TOK£N. SOURCE  CURRENT_TOK£N. SOURCE ; 
if  (T0KEN_C0DE  in  RESERVED_TOKENS)  then 
TEMP_TOKEN.TOKEN_TYPE  ;=  TOKEN_SCANNER . RESERVED, WORD ; 
elsif  (T0KEN_C00E  in  DELIMITER_TOKENS)  then 

TEMP_TOKEN.TOKEN_TYP£  TOKEN_SCANNER. DELIMI TER ; 

end  if; 

return  TEMPTOKEN; 
end  ASSIGN; 


procedure  CONV£RT_UPP£R_CASE( TOKEN  ; 

in  out  TOKEN_SCANN£R.TOKEN_RECORD_TYPE)  is 
subtype  UPP£R_CASE_LETTER  is  character  range  'A'..'Z'; 
subtype  LOWER  CASE  LETTER  is  character  range  ' a'  . ' z' ; 
begin 

for  LEXEME_INDEX  in  1 .. TOKEN . LtXEME  SI ZE  loop 

if  TOKEN. LEXEME(LEXEME_INOEX)  in  LOWER_CASE_LETTER  then 
TOKEN. LEXEME(LEXEME_INOEX)  ;= 
UPPER_CASE_LETTER'VAL(LOWER_CASE_LETTER'POS( 

TOKEN. LEXEME(LEXEME_INOEX))  -  32); 
end  if; 
end  loop; 

end  CONVERT_UPPER_CASE; 
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procedure  CONVERr_LOWER_CASE( TOKEN  : 

in  out  TOKEN_SCANNER.TOKEN_RECORD_TYPE)  is 
subtype  UPPERCASELETTER  is  character  range  'A’..'Z'; 
subtype  LOWERCASElETTER  is  character  range  ’a'..'z': 
begin 

for  LEXEME  INDEX  in  1 .. TOKEN , LEXEM£_SIZE  loop 

if  TOKEN. LEXEME(LEXEME_INDEX)  in  UPPER_CAS£_L£TTER  then 
TOKEN. LEXEME(LEXEME_INDEX)  := 

LOWER_CASE_LETTER • VAL( UPPER_CASE_LETTER ' POS( 

TOKEN. LEXEME(LEXEME_INDEX))  32); 
end  if; 
end  loop; 

end  COMVERT_LOUER_CASE; 
begin 

TOKEN_SCANNER.LOOK_TOKEN(SOURC£_FILE,  CURRENTTOKEN); 
if  (TOKEN_COOE  in  8ASIC_T0K£NS)  then 
case  TOKENCODE  is 

when  TOKENIOENTIFIER  => 

IS_SAME  :=  (CURRENT_T0KEN. TOKEN_FYP£  -  TOKEN_SCANNE R . I DENTI F I ER  ) ; 
if  (IS_SAM£)  then 

CONVERTjJPPER_CAS£(CURRENT_TOK£N); 
end  if; 

whan  TOKEN_NUMERIC_LITERAL  => 

IS_SAME  (CURRENT_TOKEN,TOKEN_TYPE  =  TOK£N_SCANNER . NUMERIC_LI T ) ; 
when  rOKEN_CHARACTER_LnERAL  => 

IS.SAME  ;=  (CURRENT_TOK£N.TOKEN_TYPE  =  TOKEN_SCANNER.CHARACTER_LIT) ; 
when  TOKEN_STRING_LIT£RAL  => 

IS_SAME  :=  (CURRENT_TOKEN.TOK£N_TYPE  ^  TOKEN_SCANNER . STRING_LI T ) ; 
when  others  =>  nul 1 ; 
end  case; 
else 

CONVERT_LOWER_CASE(CURR£NT_TOK£N); 
case  TOKEN  CODE  is 
when  TOKEN_ENO  => 

TEST_TOKEN  :=  ASSIGN( "end" ) ; 
when  TOKENBEGIN 

TEST_TOKEN  ;=  ASSIGN( "beg  in" ) ; 
when  TOKENIF  => 

TEST_TOKEN  :=  ASSIGN( " i f " ) ; 
when  TOKENTHEN  =) 

TEST_TOKEN  ;=  ASSIGN( " then"  ) ; 
when  TOKENELSIF  => 

TEST_TOKEN  ;=  ASSIGN( "el s i f “ ) ; 
when  TOKENELSE  => 

TEST_TOKEN  :=  ASSIGN( "e> se" ) ; 
when  TOKENWHILE  => 

TESTTOKEN  :=  ASSIGN) "wh i le" ) ; 
when  TOKEN  LOOP  => 

TEST_TOKEN  ASSIGN) " 1 oop"  ) ; 
when  TOKEN  CASE  => 

IESI_rOKEN  ; =  ASSIGN) "case" ) ; 
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when  TOKENWHEN  => 

TEST_TOKEN  ;=  ASSIGN( "when"  ) ; 
when  TOKEN_DECLARE  => 

TEST_T0KEN  :=  ASSIGN("declare"); 
when  TOKENEOR  -> 

TEST_TOKEN  :=  ASSIGN( " for" ) ; 
when  TOKEN_OTHERS  => 

TEST_TOKEN  :=  ASSIGN( "others" ) ; 
when  TOKEN_RETURN 

TEST_TOKEN  ;=  ASSIGN( " return" ) ; 
when  TOKEM_EXIT  O 

TEST_TOKEN  :=  ASSIGN( "exi t" ) ; 
when  TOKEN_PROCEOURE  => 

TEST_TOKEN  :=  ASSIGN( "procedure" 
when  TOKEN_FUNCTION  => 

TEST_TOKEN  :=  ASSI6N( "function") 
when  TOKEN_WITH 

TEST_T0KEN  ;=  ASSIGN("wUh”); 
when  T0I{EN_USE  => 

TEST_TOKEN  :=  ASSIGN( "use" ) ; 
when  rOKEN_PACKAGE  O 

TEST_TOKEN  ASSIGN( "package" ) ; 
when  TOkEN_BODY  => 

TEST_TOKEN  :=  ASSIGN( "body" ) ; 
when  TOKEN_RANGE  => 

TEST_TOKEN  ;=  ASSIGN( " range" ) ; 
when  TOKEN_IN  => 

TEST_TOKEN  ;=  ASSIGN( " in" ) ; 
when  T0I(EN_0UT  => 

TEST_TOKEN  :=  ASSIGN( "out" ) ; 
when  TOICEN_SUBTYPE  => 

TEST_TOKEN  :=  ASSIGN( " subtype" ) ; 
when  TOKEN_TYPE  => 

TEST^TOKEN  ASSIGN( " type" ) : 
when  TOKEN_IS  => 

TEST_TOKEN  :=  ASSIGN( " is" ) ; 
when  TOKEN_NULL  => 

TEST_TOKEN  :=  ASSIGN( " nu It " ) ; 
when  TOKEN_ACCESS  => 

TEST_TOKEN  :=  ASSIGN( "access" ) ; 
when  rOltEN_ARRAY  O 

TEST_TOKEN  :=  ASSIGN( "array" ) ; 
when  TOKEN_OIGITS  O 

TEST_TOKEN  :=  ASSIGN( "d  ig  i  ts"  ) ; 
when  T0KEN_0ELTA  -> 

TESTTOKEN  :=  ASSIGN( "de t ta" ) ; 
when  TOKENRECORDSTRUCTURE  => 
TESTTOKEN  :=  ASS IGN( " record" ) ; 
when  TOKEN_CONSTANT  => 

TESTTOKEN  ;=  ASSIGN( "constant" ) 
when  TOKEN  NEW  -> 
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TEST  TOKEN  ;=  ASSIGN(“nei«"); 
when  TOKEN_EXCEPTION  => 

TtST_TOKEN  ;=  ASSI6N( "except ion" ) ; 
when  T0KEN_RENAMES  => 

^^ST_TOKEN  ;=  ASSIGN{ " renames" ) ; 
when  TOKENPRIVATE  => 

TEST_TOICEN  :=  ASSIGN(  "private"  ) ; 
when  T0KEM_LIMITED  => 

ASSIGN(  "  1  imi  ted"  ) ; 
when  TOKEN_TASK  => 

TEST_TOI(EN  ASSIGN*  "task"); 
when  TOKEN_£NTRY  => 

IEST_T0KEN  :=  ASS  I GN( "en t ry “ ) ; 
when  TOKEM_ACCEPT  -> 

TEST_T0KEM  ;=  ASSIGN* "accept"  ) ; 
when  TOKENOELAY  => 

I^ST__TOKEN  ASSIGN* " de  1  ay ; 

when  TOKEN^SELECT  => 

IEST_T0KEN  ASS  I GN* " se 1 ec t " ) ; 

when  TOI<EN_TERMINATE  => 

IfST^TOKEN  :=  ASSIGN* "terminate" ) ; 
when  TOKEN_ABORT  O 

TEST_TOKEN  : =  ASSIGN* "abort" ) ; 
when  T0KEN_SEPARATE  => 

IEST^TOKEN  ASSIGN* "separate" ) ; 

when  TOKEN_RAISE  => 

TtST_T0K£N  :=  ASSIGN* " ra ise" ) ; 
when  rOKEN_GENERIC  => 

IEST__T0K£N  ;=  ASSIGN*  "gener  ic"  ) ; 
when  TOKEN_AT  => 

TESTTOKEN  ;=  ASSIGN* “at" ) ; 
when  T0KEN_REVERSE  =) 

TEST^TOKEN  ;=  ASSI GN* " re ve rse" ) ; 
when  T0KEN_0O  => 

T£ST_rOKEN  :=  ASSIGN* "do" ) ; 
when  T0KEN_G0T0  => 

TEST_TOKEN  :=  ASSIGN* "goto" ) ; 
when  TOKENOF 

TEST_TOKEN  ASSIGN* "of ") ; 

when  TOKENALL  => 

TEST_TOKEN  :=  ASSIGN* "alt ") ; 
when  TOKEN_PRAGMA  => 

TESr_TOKEN  ;=  ASSIGN* "pragma"  ) ; 
when  T0KEN_AN0  => 

TESTTOKEN  :=  ASSIGN* "and" ) ; 
when  T0KEN_0R  => 

TESTTOKEN  ASSIGN* "or" ) ; 

when  TOKENNOI  -> 

TEST  TOKEN  ; =  ASSIGN* " not "> ; 
when  TOKEN  XOR  O 

TESI  IOKEN  -  ASSIGNC'xor"); 


220 


when  TOKENMOD  O 

TESTTOKEN  ; =  ASSIGN( "mod” ) ; 
•hen  T0KEN_REM  => 

TESTTOKEN  :=  ASSIGN( " rem"  ) ; 
when  TOKENABSOLUTE  => 

TEST_TOKEN  :=  ASSIGN( "abs"  ) ; 
when  TOKEN_ASTERISK  => 

TEST_TOKEN  : -  ASSIGN("*"); 
when  TOKEN_SLASH  => 

TEST_TOKEN  :=  ASSIGN("/"); 
when  TOKEN_EXPONENT  :> 

TEST  TOKEN  ;=  ASSI6N( ; 
when  TOKEN_PLUS  => 

TESTTOKEN  :=  ASSIGH("*”): 
when  TOKeN_MIMUS  => 

TEST_TOKEN  :=  ASSIGN("-"); 
when  TOKENAMPERSANO 

TESTTOKEN  :=  ASSI6N("&"); 
when  TOKEN_EQUALS  => 

TESTTOKEN  ASSIGN("="); 
when  TOKEN_NOT_E0UALS  => 
TEST_TOKEN  :=  ASSIGN( "/=") ; 
when  TOKEN_LESS_THAN  => 

TESTTOKEN  ;=  ASSIGN("<"); 
when  TOKEN_LESS_THAN_E0UALS  => 
TESTTOKEN  :=  ASSIGN( "<»" ) ; 
when  TOKEN_CREATER_THAN  => 
TEST_TOKEN  :=  ASSIGN(">"); 
when  TOKEN_GREATER_THAN_EQUALS  => 
TEST_TOKEN  ASSI6N( ">=" ) ; 

when  TOKEN_ASSIGNMENT  O 
TEST_TOKEN  :=  ASSIGN( " : ; 
when  TOKEN_COMMA  => 

TEST_TOKEN  ASSIGN(","); 

when  TOKEN_SEMICOLON  => 

TESTTOKEN  :=  ASSJGN(":"); 
whan  TOKEN_PERIOO  => 

TEST_TOKEN  ;=  ASSIGN(" 
when  TOKEN_LEFT_PAREN  O 
TESTTOKEN  :=  ASSIGN("("); 
when  TOKENRIGHTPAREN  => 
TESTTOKEN  :=  ASSIGN(")"); 
when  T0KEN_C0L0N  => 

TESTTOKEN  ;=  ASSIGN(":"): 
when  TOKENAPOSTROPHE  => 
TESTTOKEN  :=  ASSIGN("'"); 
when  TOKEN_RANGE_OOTS  -> 
TESTTOKEN  :=  ASSIGN( " . 
when  TOKEN_ARROW  => 

TESTTOKEN  ASS  I GN( " ; 
when  TOKEN  BAR  -> 


221 


TEST_TOKEN  ASSIGN("|"): 

»hen  TOKEN_BRACKETS  => 

TESTTOKEN  :=  ASSIGN( "<>" ) ; 
when  TOKEN_LEFT_BRACKET  -> 

TEST  TOKEN  ASSIGN( : 

when  TOKENRIGHTBRACKET  => 

TEST_TOKEN  :=  ASSIGN( " >>" ) ; 
when  others  =>  null; 
end  case; 

IS_SAME  :=  (CURRENTTOKEN  =  TESTTOKEN): 
end  if; 

if  (1S_SAME)  then 

HOLD_TOKEN  :=  CURRENTTOKEN ; 

TOKEN_SCANNER.CONSUME_TOKEN(SOURCE_FILE); 
end  if; 

return  (IS_SAME); 
end  MATCH; 

procedure  MATCHEO_TOKEN( TOKEN  :  out  TOKENSCANNER . TOKEN_RECORD_TYPE )  is 
--  pre  -  TOKENMATCHER  has  been  set  up  and  at  least  one  call  to  the 
function  MATCH  has  returned  TRUE; 

--  post  -  TOKEN  contains  the  token  that  caused  the  last  call  to  MATCH 

to  be  TRUE.  NOTE  -  All  identifiers  are  converted  to  upper  case 
by  the  token  matcher  and  all  reserved  words  are  converted  to  lower 
case  by  the  token  matcher  regardless  of  the  format  in  the  source 
code.  All  other  token  types  are  uneffected  by  the  token  matcher. 

begin 

TOKEN  ;=  H0LD_T0KEN; 
end  MATCHEO_TOKEN; 

procedure  CURRENT_T0KEN( TOKEN  ;  out  TOKEN_SCANNER . TOK£N_RECORD_TyPE )  is 
--  pre  -  TOKEN_MATCHER  has  been  set  up. 

--  post  -  TOKEN  contains  the  token  that  is  under  the  TOKEN_SCANNER ’ s 
read  head. 

begin 

TOKEN_SCANNER . LOOK_TOKEN( S0URCE_F ILE ,  TOKEN) ; 
end  CURRENTTOKEN; 

procedure  NEXT_TOKEN( TOKEN  :  out  TOKEN_SCANNER . TOKEN_REC0RD_TYPE )  is 
--  pre  -  TOKEN_MATCHER  has  been  set  up. 

--  post  -  TOKEN  contains  the  token  that  is  next  to  be  read  by  the 
TOKEN_SCANNERS  read  head. 

begin 

TOKENSCANNER . LOOK_AHE A0_T0KEN( SOURCE_FILE ,  TOKEN) ; 
end  NEXT_TOKEN; 

function  LINES_CHECKEO  return  positive  is 
--  pre  -  TOKENMATCHER  has  been  set  up. 

--  post  -  returns  the  number  of  1 ines  of  code  that  have  been  checked 
by  the  TOKEN  MATCHER. 

beg  i  n 
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return  ( TOKEN_SCANNE« . LINES_SCANN£0(SOURCE_FIL£ ) ) ; 
end  LINES_CHECKED; 

function  VALIO_COMMENTS  return  natural  is 
--  pre  -  TOKEN_MATCHER  has  been  set  up. 

--  post  -  returns  the  number  of  "meaningful”  comments  seen  by  the 

TOKEN_MATCHER .  A  "meaningful"  comment  is  defined  as  a  comment 
that  contains  at  least  one  letter  or  digit. 

begin 

return  (TOttEN_SCANMER  .CQM«ENTS_SCANNED(SOUBC£_FIL£) ) ; 
end  VALID_COMMENTS; 

end  TOKEN  MATCHER; 
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APPKNDrX  H 


”A  DA  FLOW”  PROGRAM  LISTING  •  TOKEN  SCANNER 


TITLE: 

E.0AFL0W 

MODULE  NAME: 

PACKAGE  TOKENSCANNER 

-- 

FILE  NAME: 

TOKEN. ADS 

-- 

DATE  CREATED: 

02  FEB  83 

-- 

LAST  MODIFIED: 

26  APR  88 

-- 

AUrHOR(S) : 

LT  albert  J.  GRECCO.  USN 

DESCRIPTION: 

This  package  defines  the  interface  to  the 

token  scanner  module. 

-* 

with  T£XT_IO; 

package  TOKEM_SCANN£R  1s 

--  maximum  number  of  chars  per  line  in  file  being  parsed 
LINESIZE  :  constant  integer  :=  13Z; 

ENOFILE  ;  constant  character  :=  ASCII. sub; 

ENOLINE  :  constant  character  :=  ASCII. eot; 

--  'DA  token  classes 

type  TOKEN_CLASS  is  ( RESERVED_WORO .  IDENTIFIER,  SEPARATOR.  NUMEfiIC_LIT, 
DELIMITER,  COMMENT,  CHARACTERLIT ,  STRIN6_LIT, 
UNOEF_CHAR,  EOF); 

--  record  to  indicate  where  a  token  came  from 
type  SOURCEHECORO  is 
record 

FILENAME  :  s t r i ng( 1 . . L I NE SI ZE )  (others  ->  '  ’); 

FILE_NAME_SIZE  :  natural  :=  0; 

LINENUMBER  :  natural: 
end  record: 

record  to  hold  the  token  built  up  by  the  token  scanner,  the  LEXEME  is 
-  the  actual  string  for  that  particular  token  and  LEXEMESIZE  is  the 
-  number  of  characters  in  the  lexeme  string.  SOURCE  indicates  the 
location  in  the  source  file  where  the  token  originated. 
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type  TOKEN_RECORD_rYPE  is 
record 

TOKENTYPE  ;  TOKENCLASS; 

LEXEME  ;  s t ri ng( 1 . . L INESI ZE )  (others  =>  '  '); 

LEXEMESIZE  ;  natural  :=  0; 

SOURCE  :  SOURCE_RECORD; 

and  record; 

--  raising  of  any  of  the  following  exceptions  indicates  that  an  illegal 

--  token  has  been  scanned  into  the  look  ahead  token.  In  the  case  of  an 

--  exception,  procedure  LOOKTOKEN  is  undefined,  while  procedure  LOOK_ 

--  AHEAD_TOKEN  can  provide  access  to  the  lexeme  that  raised  one  of  the 
--  scanner  exceptions. 

ILLEGAL_IDENTIFIER  ;  exception; 

ILLEGAL_NUMERIC_LIT  :  exception; 

ILLEGAL_STRING_LIT  :  exception; 

ILLEGALCHARACTER  ;  exception; 

procedure  SET_UP_TOkEN_SCANNER(PARSE_FILE  :  in  TEX T_ 10 . f 1 1 e_type  ) ; 

--  pre  -  must  be  called  before  any  other  procedure  in  the  token 

scanner  module.  Only  one  file  may  be  set  up  at  a  time. 

PARSE_FILE  must  be  open  and  rewound  before  token  scanner 
can  be  set  up. 

procedure  RELEASE_TOI(EN_SCANNER(PARSE_FILE  ;  in  out  TEXT_I0.  f  i  1  e_type ) ; 

--  pre  -  T0KEN_SCANNER  has  been  set  up. 

--  post  -  All  T0KEN_SCANN£R  interfaces  are  undefined  with  the  exception 
of  SET_UP_TOkEN_SCANNER.  The  TOKEH_SCAnNER  must  be  released 
prior  to  main  program  termination.  PARS£_fILE  is  closed. 

procedure  L00K_T0XEN( PARSEF I L£  ;  in  TEXTIO. f i 1 e_type ; 

TOKEN  :  out  TOK£N_RECORD_TYPE ) ; 

--  pre  -  scanner  has  been  set  up  and  an  exception  has  not  occurred. 

--  post  -  TOKEN  contains  the  token  under  the  read  head  in  PARSE_FILE. 

The  scanner  filters  out  comments  and  separators. 

procedure  L00K_AHEAD_T0KEN( PARSEF ILE  :  in  TEXTIO . f i 1 e_type ; 

TOKEN  :  out  TOKEN_RECORD_TYPE ) ; 

--  pre  -  scanner  has  been  set  up. 

--  post  -  TOKEN  contains  the  next  token  to  come  under  the  read  head  in 
PARSE_FILE.  The  scanner  filters  out  comments  and  separators. 

procedure  CONSUME_TOKEN(PARSE  FILE  :  in  TEXTIO. f ile_type) ; 

--  pre  -  scanner  has  been  set  up. 

--  post  -  the  read  head  is  advanced  one  token  in  PARSEFILE. 

The  scanner  filters  out  comments  and  separators. 

function  L IN£S_SCANNE0( PARSEF lEE  in  TEXTIO . f i 1 etype )  return  positive; 
--  pre  -  scanner  has  been  set  up. 

-  post  -  returns  the  number  of  lines  in  PARSEFILE 

that  have  been  scanned  by  the  token  scanner. 
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function 
--  pre 
--  post 


end  TOKEN 


COMMENTS_SCANNED(PARS£_f ILE  ;  in  TEX T_I0 . f r 1 e_ 

-  scanner  has  been  set  up. 

-  returns  the  number  of  "meaningful"  comments  i 
that  have  been  scanned  by  the  token  scanner, 
comment  is  defined  as  a  comment  that  contains 
letter  or  digit. 

SCANNER: 


type)  return  natural 

n  PARSE_f.LE 
A  "meaningful" 
at  least  one 
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TITLE: 


ADAFLOW 


--  MODULE  NAME:  PACKAGE  TOKEN_SCANNER 

--  FILE  NAME:  TOKEN. ADB 

--  DATE  CREATED;  02  FEB  88 

--  LAST  MODIFIED:  26  APR  88 

--  AUTHOR(S):  LT  ALBERT  J,  GRECCO.  USN 

--  DESCRIPTION-  This  package  contains  the  procedures  »hich 
implement  the  TOKEMSCANMER . 


with  ItXT_IO; 

package  body  TQKEN_SCANNER  is 

CURRENT_TOKEN  :  TOKEN_RECORD_TYPE ; 
N£XT_TOKEN  ;  TOKEN_fiECORD_TYPE ; 
LINE_TOTAL  ;  positive  :=  I; 
COMMENT_TOTAL  :  natural  0; 


package  BUIL0_T0KEN_PIPE  is 

procedure  INITIALIZE_TOKEN_PIPE ; 

procedure  GET_TOK£N( TEXIF ILE  :  in  TEXT_IO.f ile_type; 

TOKEN  ;  out  T0KEN_REC0RD_TYPE ; 

IS_VALIO  ;  out  boolean); 

end  8UIL0_T0KEN_PIPE: 


package  body  BU1L0_T0KEN_PIPE  is 


subtype 

UPPER_ 

CASE, 

LETTER 

is 

character 

range 

'A'  . 

. '  Z' 

subtype 

L0W£R_ 

CASE, 

LETTER 

is 

character 

range 

' a'  . 

i' 

subtype 

UPPER_ 

CASE, 

HEX 

is 

character 

range 

'A'  , 

.  '  F  • 

subtype 

LOWER, 

CASE, 

HEX 

is 

character 

range 

'a' . 

,  '  f  ' 

subtype 

DIGITS 

;_TYPE 

is 

character 

range 

■O' . 

,  '9’ 

subtype 

FORMAT 

_EfFECTOR 

IS 

character 

range 

ASCII .HT 

subtype  CHARLITTYPE  is  character  range  ' 

type  L00K_UP_TA8LE  is  array  (LOWER_CASE_L£TTER)  of  natural; 

type  STRINGMATRIX  is  array  (positive  range  1..63)  of  s t r ing{ 1 . . 9  ) ; 

RESERVE0_W0RD_MATR1X  ;  S 1 R I NG_MArRI X  ;  = 

(("abort  "),(”abs  ”), ("accept  "), ("access  "). 

("all  ").("and  "), ("array  ").("at 

("begin  "),("body  "),("case  " ) , ( "cons tanl  "  )  , 
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•w 


ir 


f 


( "declare 

" ) , ( "delay 

" ) , ( "delta 

"), ("digits 

( "do 

" ) , ( "else 

"), ("elsif 

" ) , ( "end 

( "entry 

" ) , ( "exception 

").("exit 

">,("for 

( "function 

" ) , ( "generic 

"),("goto 

").("if 

("in 

").("is 

"),("! imited 

").("loop 

■’). 

( "mod 

" ) , ( "new 

").("not 

"),("null 

("of 

").("or 

"), ("others 

").("out 

( "package 

"),( "pragma 

" ) , ( "priwate 

" ) ,  ( "procedure 

( "raise 

"),(" range 

" ) ,( "record 

"),("rem 

( "renames 

" ) , ( " return 

" ) , ( "reverse 

" ) , ( "select 

( "separate 

" ) ,  ( "subtype 

" ) , ( "task 

" ) . ( "terminate 

( "then 

"),("type 

" ) , ( "use 

"),("when 

( "while 

"),("with 

").("xor 

")): 

RESERVED_WORD_HASH  :  LOOK_UP_TABLE  := 

((1).(9).(U),(  13).(18).(24).(26).(0).(28),(0),(0).(31).(33). 
(34).(37).(41).(0),(45).(52),(55).(59).(0).(60).(63).(0).(0)); 
CH  :  character  : =  '  ' ; 

CH_HOLD  :  character 

INITIAL_TOKEN  ;  boolean  :=  TRUE; 

PARTIAL_TOKEN  :  boolean  FALSE; 

TOKEN_WAITING  :  boolean  :=  FALSE; 

TOKEN_HOLD  :  TOKEN_RECORO_TYPE ; 

package  GET_CHAR_PIP£  Is 

procedure  GET_CHARACTER( TEXT_FILE  :  in  TEXT_IO. f i le_type ; 

CH  :  out  character); 

end  GET_CHAR_PIPE; 


package  body  GET_CHAR_PIPE  is 

procedure  GET_CHARACTER( rEXT_FILE  ;  in  TEXT_I0 . f i le_type ; 

CH  ;  out  character)  is 

begin 

if  TEXT_IO.ENO_OF_FILE(TEXT_FILE)  then 
CH  :=  ENOFILE; 

elsif  TEXT_IO.END_OF_LINE(TEXT_FILE)  then 
TEXT_IO.SKIP_LINE(TEXT_FILE); 

CH  :=  ENDLINE; 
else 

TEXT_IO.get( TEXTFILE ,  CH); 
end  if; 

end  GETCHARACTER, 
end  GET  CHARPIPE; 


procedure  INITIALIZE_TOKEN_PIPE  is 
begin 

CH  ; =  ■  '  : 

CHHOLD  :=  ■  '; 

INITIAL_TOKEN  :=  TRUE; 
PARTIAL_TOKEN  :=  FAISE; 
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TOKEN_WAITING  :=  FALSE; 
end  INITIALIZE_TOKEN_PIPE; 

procedure  GET_T0KEN( TEXTFILE  ;  in  TEXTIO. f i le_type ; 

TOKEN  :  out  rOKEN_RECORD_TYPE ; 

IS_VALI0  :  out  boolean)  Is 
LEXEMECOUNT  :  positive  ;=  1; 

STATE  :  positive  :=  1; 

TESTLEXEME  :  string( 1 , . LINESIZE ) ; 

SHARP_REPLACEMENT  :  boolean  ;=  FALSE; 

OUOTE_REPLACEMENT  :  boolean  :=  FALSE; 

function  IS_RESER\/ED( TEST_LEXEME  :  in  string)  return  boolean  is 
LEXEME  :  string(1..9)  :=  (others  =>  '  '); 

IS_MATCH  ;  boolean  ;=  FALSE; 

ROW  ;  natural; 

INDEXCHAR  ;  character; 

HASHSTOP  :  natural; 

begin 

if  (TESTLEXEME' LENGTH  <=  9)  then 

LEXEME(TEST_L£XEME’RANGE)  :=  TESTLEXEME; 
for  I  in  TEST_LEXEME' RANGE  loop 

if  ((LEXEME(I)  in  OIGITS_TYPE)  or  else  (L£XEME(I)  =  '_'))  then 
return  (FALSE); 

elsif  (LEXEME(I)  in  UPPER_CASE_LETTER)  then 
LEXEME(I) 

L0WER_CASE_LETTER'VAL(UPPER_CASE_LETTER'P0S(LEXEME(I))  t  32) 
end  if; 
end  loop; 

case  ( LEXEM£(  1 ) )  is 

when  ' h ' I ' j ’ I ' k ' I ' q ' I ' V ■ I ' y ' I ' t '  => 
return  (FALSE); 
when  others 

ROW  ;=  RESERVED_W0RD_HASH(LEXEM£(1)); 
if  (LEXEM£(1)  =  'x')  then 
HASHSTOP  :=  63; 
else 

INOEXCHAR  ;=  character ' SUCC( LEXEME( 1 )) ; 
while  (RESERVEO_WORO_HASH(INOEX_CHAR)  =  0)  loop 
INOEX_CHAR  :=  character ' SUCC( INOEXCHAR ) ; 
end  loop; 

HASH_STOP  :=  RESERVED_WORD_HASH( INOEXCHAR) ; 
end  if; 

while  ((ROW  <=  HASH_srOP)  and  then  (not  IS_MATCH))  loop 
IS_MATCH  ;=  (LEXEME  =  RESERVE0_WORO_MATRIX( ROW) ) ; 

ROW  ROW  +  1; 
end  loop; 

return  (IS_MAICH); 
end  case; 
else 

return  (FALSE); 
end  if; 
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end  IS_RESERVED; 
begin 

TOKEN. LEXEME  :=  (others  =>  '  '); 

TOKEN. SOURCE. F I LE_NAME  :=  (others  =>  '  '); 
if  (INITIAL^TOKEN)  then 

G£T_CHAfiJ>[PE.GEr_CHARACT£R(TEXT_FIL£,  CHHOLO); 

INITIAL_TOKEN  :=  FALSE; 
end  if; 

if  ((CH  /=  ENOfILE)  and  then  (not  TQKEN_WAITING)  and  then 
(not  PARTIAL_TOK£N))  then 
CH  :=  CHHOLO; 

GET_CHAR_PIP£.G£T_CHAfiACTER{TEXT_FrL£,  CHHOLO); 
elsif  (PARTrAL_TOKEN)  then 
PARTIAL_TOKEN  FALSE; 
end  if; 

if  TOKENWAITING  then 
TOKEN  :=  TOKENHOLO; 

IS_VALIO  ;=  TRUE; 

TOKEN_WAITING  : =  FALSE; 

eTsif  ((CH  in  UPPER_CASE^LETT£R)  or  else  (CH  in  l0WER_CASE_LETTER) )  then 
TOKEN. TOKEN^TYPE  ; =  lOENTIFIER; 

TOKEN. SOURCE. LINE_NUMBER  ;=  LlN£_TOTAL; 

TOKEN.  SOURCE.  F I  LE_NAME_SUE  ;=  TEXT_IQ .  name(  TEXT_f  ILE )' LENGTH; 

TOKEN. SOURCE. FILE_NAME(1. . TEXT_IO.name( TEXT_FILE ) 'LENGTH) 
TExT_IO.na(ne(T£XT_FILE); 

TOKEN. L£XEME(L£X£M£_C0UNT)  ;=  CH; 

TEST_L£X£M£(lEX£M£_COUNT)  :=  CH; 
loop 

case  STATE  is 

when  1  =>  if  ((CH_H0L0  in  UPPER_CASE_LETTER)  or  else 
(CH_H0LD  in  LOWER_CASE_LETTER)  or  else 
(CH_H0LD  in  DIGITS.TYPE))  then 
LEXEME_COUNT  :=  LEXEME_COUNT  <•  1; 

TOKEN. LEXEME(LEXEHE_COUNT)  CH_HOLD; 
TEST_LEXEME(LEXEME_COUNT)  CH_HOLO; 

GE  T_CHAR_r iPt .G£I_CHARACTER( TEXT  FILE .  CH_HOLD) ; 
elsif  (CHHOLO  =  '_•)  then 
STATE  :=  2; 

LEXEMECOUNT  :=  LEXEME_COUNT  r  1; 

TOKEN. LEXEME(L£XEME_COUNT)  ; =  CH_HOLO; 
TEST_LEXEME(LEXEME_C0UN1 )  ;=  CHHOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE.  CH_HOLD); 
e  I  se 

if  (IS_fi£S£RVEO(TEST_LEX£M£( 1. .LEXEME^COUNT)))  then 
TOKEN. TOKEN_TYPE  :=  RESERVED_WORD; 
end  if; 

TOKEN. LEXEME  SIZE  ;=  LEXEME_COUNT; 

IS_VALIO  :=  TRUE; 
exit; 
end  if; 

when  Z  >  if  ((CH  HOLD  in  UPPE RCASELE TTE R )  or  else 
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(CH_HOLD  in  LOWER_CASE_L£TTER)  or  else 
(CH_HOLD  in  DIGI TS_TYPE ) )  then 
STATE  :=  1; 

LEXEME_COUNT  LEXEME_COUNT  +  1; 

TOKEN. LEXEME(LEXEME_COUNT)  ;=  CH_HOLD: 
TEST_LEXEME(LEXEM£_COUNT)  :=  CH_HOLO; 
GET_CHAR_PIPE.G£T_CHAHACTER(TEXT_FIL£,  CHHOLO) 
else 

IS_VALID  FALSE; 

TOKEN, LEXEME_SIZE  :=  LEXEM£_COUNT ; 
exit; 
end  if; 

when  others  =>  null; 
end  case; 
end  loop; 

elsif  ((CH  in  FORMAT_EFFECTOR)  or  else 

(CH  =  ■  ' )  or  else  (CH  =  ENOLINE))  then 
TOKEN. TOKEN_TYPE  ;=  SEPARATOR; 

TOKEN. SOURCE. LINENUMBER  :=  LINE_TOTAL; 

TOKEN. SOURCE. FILENAMESIZE  :=  TEXT_IO . name( TEX T_F I LE )' LENGTH ; 
TOKEN. SOURCE. FILE_NAME( 1. .TEXT_10.name(TEXT_FILE)’LENGTH)  := 
TEXT_IO.naine(TEXT_FIL£); 

TOKEN. LEXEME(LEXEME_COUNT)  CH; 
if  (CH  °  ENOLINE)  then 

LINETOTAL  :«  LINE_TOTAL  +  1; 
end  if; 

--  go  ahead  and  flush  out  the  rest  of  the  separators  as  they  wi 
--  discarded  anyway 

while  ((CH_HOLO  in  F0RMAT_Ef FECTOR)  or  else  (CH_HOLD  =  ’  ' )  or 
(CH_HOLO  =  ENOLINE))  loop 

LEX£ME_COUNT  ;=  LEXEME_COUNT  «•  1; 

TOKEN. LEXEME(L£XEME_COUNT)  :=  CH_HOLO; 
if  (CH_H0L0  =  ENOLINE)  then 
LINE_TOTAL  :=  LINETOTAL  *  1; 
end  if; 

GET  CHAR  PIPE .GET_CHARACTER( TEXT  FILE  .  CH  HOLO) ; 
end  loop; 

TOKEN. LEXEME_SIZE  :=  LEXEMECOUNT ; 

IS_VALI0  :=  TRUE; 
elsif  (CH  in  OIGITS_TYPE)  then 
TOKEN. TOKEN_TYPE  ;=  NUMERIC_LIT; 

TOKEN. SOURCE. LINE_NUMBER  :=  LINETOTAL; 

TOKEN. SOURCE. FILE_NAME_SIZE  :=  TEXT_IO.naitie(  TEXTFILE  )’ LENGTH  ; 
TOKEN.  SOURCE.  FILENAME!  1.  .  TE  XTIO .  nanie(  TEXTF ILE  )’ LENGTH )  :  = 
TEXT_IO.name(T£XT_FILE); 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CH; 
loop 

case  STATE  is 

when  1  O  if  (CHHOLO  in  01GITS_TYPE)  then 

LEXEME  COUNT  :=  LEXEMECOUNT  +  1; 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CH  HOLD; 


11  be 
else 
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GE  T_CHAR_P I  PE . GET_CHARAC  TER( TEX  T_F I L£ ,  CH_HOLD ) ; 
elsif  (CHHOLD  =  • . • )  then 
STATE  :=  2; 

LEXEME_COUNT  :=  LEX£ME_COUNT  +  1; 

TOKEN. LEXEME (LEXEME_COUNT)  ;=  CH_HOLD: 
GET_CHAR_PIPE.G£T_CHARACTER(TEXT_FILE,  CH_HOLD); 
elsif  ((CH_HOLD  =  •£’)  or  else  (CH_HOLD  =  'e'))  then 
STATE  :=  17; 

LEXEME_COUNT  ;=  LEXEME_COUNT  +  1; 

TOKEN. LEXEM£(LEX£M£_COUNT)  :=  CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FIL£,  CH_HOLD); 
elsif  (CHHOLD  =  •_■)  then 
STATE  9; 

LEXEME_COUNT  :=  LEXEME_COUNT  ♦  1; 

TOKEN. LEXEME(LEX£M£_COUNT)  ;=  CH_HOLO; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE,  CH_HOLD); 
elsif  ((CH_HOLD  =  '#')  or  else  (CH_HOLD  =  then 

SHARP_REPLACEHENT  ;=  (CH_HOLD  = 

STATE  :=  10: 

LEXEME_COUNT  LEXEME_COUNT  ♦  1; 

TOKEN. LEX£ME(LEXEME_C0UMT)  :=  CH_HOLP: 

GETCHAR  PIPE . GET_CHARACTER( TEXTFILE ,  CH_HOLD) ; 
elsif  ((CH_HOLD  in  UPPERCASELETTER)  or  else  (CH_HOLD  in 
LOW£R_CASE_LETTER ) )  then  — must  be  a  separator 
--between  a  numeric  literal  and  an  Identifier. 

TOKEN. LEX£ME_SIZ£  :=  LEXEM£_COUNT: 

IS_ VALID  FALSE: 
exit: 
e  I  se 

TOKEN, LEXEM£_SIZE  :=  LEXEMECOUNT ; 

IS_VALIO  ; =  TRUE, 
exit; 
end  if; 

when  2  =>  if  (CH_HOLO  in  OIGITS_TYPE)  then 
STATE  3; 

LEXEME_COUNT  :=  LEXEME_COUNT  +  1; 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CHHOLD; 

GETCHARPIPE ,GEr_CHARACTER( TEXTFILE.  CHHOLD); 
elsif  (CH_hOLD  =  then  --test  for  range  dots 

TOKEN. LEXEME(lEXEME_COUNT) 

TOKEN. LEXEMESIZE  LEXEMECOUNT  -  1; 

IS_VALID  :=  TRUE; 

TOKEN_HOLO. TOKEN_TYPE  :=  DELIMITER; 

TOKEN_HOLO.LEXEME( 1. .2) 

TOKEN_HOLD.LEXEME_SIZE  :=  2; 

TOKEN_HOLD. SOURCE .LIMENUMBER  :=  LINETOTAL; 

T0KEN_H0LD . SOURCE . F I LE_NAME_SI ZE  : = 

TEXT_IO.name( IEXT_F ILE )• LENGTH ; 

TOKEN_HOLD.  SOURCE.  F  UE_NAME(  1.  .  TEXT  JO. 

name(TEXT  FILE)'LEMGTH)  ;=  TEXT  10 . name( TEXT  F 1 LE  ) : 

GET  JHAR  PIPE  .GET  JHARACIE  R(  TEXT  FILE  ,  CH  HOLD) ; 
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yr 


when  3 


i 

\ 

r 


when  4 


when  b| 


TQKEN_WA[TIN6  :=  T«UE : 
exit; 
else 

TOKEN. LEXEME_SI2E  ;=  LEXEM£_COUNT: 
IS^VALIO  :=  FALSE; 
exit; 
end  if; 

=>  if  (CHHOLO  in  OIGITS_TYPE)  then 

LEXEME_COUNT  :=  LEX£ME_COUMT  t  1; 
TOKEN. LEXEME(LEXEME_COUNT)  :=  CH_H0L0; 
GET_CHAR_PIPE.G£T_CHARACTER(TEXT_FILE, 
elsif  ((CHHOLO  =  *£')  or  else  (CH_H0LD 
STATE  ;=  4; 

LEXEME_CQUNT  LEX£ME_COUMT  ♦  t; 
TOKEN. LEX£M£(LEX£ME_COUNT)  :=  CH_HOLD; 
GET_CHAR_PIPE .GET_CHARACTER{ TEXT_FILE . 
elsif  (CH_H0LD  »  then 

STATE  ;=  5; 

LEXEMECOUNT  :=  LEX£ME_COUNT  +  1; 
TOKEN. LEXEME(L£XEME_COUNT)  :=  CH^HOLD; 
GET_CHAR_PIPE .GET_CHARACT£R( TEXT_FILE , 
elsif  ((CH_HOLO  in  UPPER_CAS£_LETT£R)  or 
LOWER_CASE_LETTER))  then 
TOKEN. LEXEME_SIZE  L£XEME_COUNT ; 
rS_VALIO  :=  FALSE; 
exit; 
else 

TOKEN. LEXEME_S12E  ;=  L£X£M£_C0UNT ; 
IS_VALI0  ;=  TRUE; 
exit; 
end  if; 

=>  if  ((CH_HOLO  =  •♦•)  or  else  (CH_HOLD  =  ' 
STATE  :=  6; 

LEXEME_COUNT  :=  LEXEM£_COUNT  +  1; 
TOKEN. LEXEME(LEX£ME_COUNT)  ; »  CHHOLO; 
GET_CHAR_PIPE .6ET_CHARACTER( TEXTFILE , 
elsif  (CH_HOL0  in  0IGITS_TYPE)  then 
STATE  :=  7; 

LEXEME _COUMT  :=  LEXEME_COUNT  1; 
TOKEN. LEXEME(LEXEMe_COUNT)  ; =  CH_HOLO; 
GET_CHAR_P[PE .GET_CHARACTER( TEXT  FILE  . 
e  I  se 

TOKEN. LEXEME_SI2E  LEXEME  COUNT; 
IS_VALlO  FALSE; 
exit; 
end  if; 

6|8|9  =>  if  (CHHOLO  in  OIGITS_TYPE)  then 


case  STATt 

IS 

when  5 

=  > 

STATE 

when  6|S 

=  > 

state 

when  9 

=  > 

STATE 

CH_HOLO); 

•  ’e’))  then 


CHHOLO); 


CH_HOLO); 
else  (CH_h0LD  in 


- '  ) )  then 


CH_H0L0) ; 


CH_HOLD) ; 
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when  others  ->  null; 


end  case: 

LEXEMECOUNT  LEXEME_COUNT  +  1; 

TOKEN. LEXEME(LEXEME_COUNr)  ;=  CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE,  CH_H0LD) ; 
else 

TOKEN. LEXEMESIZE  :=  LEXEME_COUN T ; 

IS_VALID  :=  FALSE; 
exit; 
end  if; 

when  7  =>  if  (CHHOLD  in  OIGITS_TVPE)  then 

LEXEMe_COUNT  -.=  LEXEM£_COUNT  t  1; 

TOKEN. LEXEME(LEXEM£_COUNT)  ;=  CH_HOLD: 
GET_CHAR_PIPE.GET_CHARACT£R(TEXT_FILE,  CH_H0L0): 
elsif  (CH_HOLD  =  '_■ )  then 
STATE  ;=  8; 

LEXEMECOUNT  :=  LEXEM£_COUNT  +  1; 

TOKEN. L£XEM£(LEXEM£_COUNT)  :=  CHHOLD; 
GET_CHAR_PIPE.GET_CHARACT£R( TEXTF ILE,  CH_HOLD) ; 
elsif  ((CH_H0LD  in  UPP£R_CASE_LETTER )  or  else  (CHHOLD  in 
LOWER_CASE_L£TTER))  then 
TOKEN. LEXEM£_SI2E  :=  LEXEMECOUNT ; 

IS_VAL1D  ;=  FALSE; 
exit; 
else 

TOKEN. LEX£ME_SIZE  :=  LEX£ME_COUNT ; 

IS_VALI0  :=  TRUE; 
exit; 
end  If; 

when  10  =>  if  ((CH_H0LD  in  DIGITS_TYPE)  or  else 
(CH_H0L0  in  UPPER_CAS£_HEX )  or  else 
(CH_HOLO  in  LOWER_CASE_HEX) )  then 
STATE  ;=  11; 

LEX£ME_COUNT  ;=  L£XEME_COUNT  ♦  1; 

TOKEN. LEXEME(LEXEM£_COUNT)  ;=  CHHOLD; 

GETCHARPIPE .GET_CHARACTER( TEXTFILE ,  CH.HOLD) ; 
elsif  ((CHHOLO  =  •  =  ■)  and  then  ( SHARPREPLACEHENT ) )  then 
SHARPREPLACEMENT  ;=  FALSE; 

TOKEN. LEXEME(LEXEME_COUNT) 

TOKEN. LEXEME_SIZE  ;=  LEXEME_COUNT  -  1; 

IS_VALIO  :=  TRUE; 

TOKENHOLO.TOKENTYPE  ;=  DELIMITER; 

TOKEN_HOLO.LEX£M£(t. .Z)  : - 
TOKENHOLO.LEXEMESIZE  ;=  Z; 

TOKENHOLD. SOURCE. LINE_NUMBER  ; =  LINETOTAL; 

TOKENHOLO. SOURCE. FI LE_NAME  SIZE  ;= 

TEXT  10. name( TEX TFILE)' LENGTH; 

TOKENHOLO. SOURCE. FILE_NAME( 1 . . TEXTIO. 

name(  TEXTFILE) ’LENGTH)  ;  =  TEXTIO .  narne(  TEXTF  I LE  ) ; 
GETCHARPIPE .GET_CHARACT£R{ TEXT  FILE.  CH_HOLD) ; 

TOKEN  WAI riNG  TRUE; 
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wnen 


when 


when  I 


en  1 1 ; 
eUe 

TOKEN.  LEXEMESUE  ;=  LEXEME  ^COUNT  ; 

IS_VALID  :=  FALSE; 
exit; 
end  if; 

11  ->  If  ((CHHOLD  in  OIGITS_TYPE)  or  else 
(CH_H0LD  in  UPPER_CASE_HEX)  or  else 
(CHHOLO  in  LOWER_CASE_HEX))  then 
LEXEME_COUNr  :=  LEXEME_COUMT  ♦  1; 

TOKEN. LEXEME(LEX£M£_COUNT)  ;=  CH_HOLD; 

G£T_CHAR_PIPE .GET_CHARACTER( TEXTFILE.  CH_H0LD) ; 
elsif  (CHHOLD  =  • . • )  then 
STATE  :=  14; 

LEXEMECOUNT  ;=  LEXEMECOUNT  +  1; 

TOKEN. LEXEM£(L£XEME_C0UNT)  -  CH_H0LD; 
GET_CHAR_PIPE.G£T_CHARACTER(TEXT~F1LE,  CH_H0LD); 
elsif  (CHHOLO  =  )  then 

STATE  :=  12; 

LEXEME_COUNT  ; =  LEXEME_COUNT  t  1; 

TOKEN. LEXEME(LEXEME_C0UMT)  ;=  CHHOLD; 
GET_CHAR_PIPE.G£T_CHARACTER(TEXT_FILE,  CH_HOLD); 
elsif  (((CH_HOLD  =  '#•)  and  (not  SHARP_REPLACEMENT) )  or 
else  {(CHHOLD  =  ’:•)  and  SHARP  REPLACEMENT))  then 
STATE  :=  13; 

LEX£ME_CQUNT  ;=  LEXEM£_COUNT  +  1; 
token. L£XEME(LEX£ME_COUMT)  ;=  CH_H0LD; 
G£T_CHAfi_PIPE.GET_CHARACTER(TEXT_fILE,  CH_H0LD); 
else 

TOKEN. LEXEME_SIZE  :=  LEXEME_COUNT; 

IS_VALID  ;=  FALSE; 
exit; 
end  if; 

12|14|16  =>  if  ((CHHOLD  in  D161TS_TYPE)  or  else 
(CH_HOLD  in  UPPER_CASE_HEX )  or  else 
(CHHOLO  in  LOWER_CASE_HEX ) )  then 
case  STATE  is 

when  12  =>  STATE  ;=  II; 

when  14116  =>  STATE  ;=  15; 
when  others  =>  null; 
end  case; 

LEXEMECOUNT  LEXEMtCOUNT  +  1; 

TOKEN. LEXEME(LEXEME_C0UNT)  ;=  CHHOLO; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_fILE.  CH_HOLD); 
else 

TOKEN. LEXEME_SIZE  LEXEME_COUNT ; 

IS_VALI0  :=  FALSE; 
exit; 
end  if; 

3  =>  if  ((CH  HOLD  -  '£')  or  else  (CHHOLD  =  'e))  then 
STATE  ;=  17; 
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LEXEMECOUNT  :=  LEXEME_C0UNT  +  1; 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CH_HOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE.  CH_HOLD); 
elsif  ((CH_HOLO  in  UPP£R_CASE_LETTER )  or  else  (CHHOLD  in 
LOWER  CASE_LETTER))  then 
TOKEN. LEXEME_SI2E  :=  L£X£ME_COUNT ; 

IS_VAH0  :=  FALSE: 
exit: 
else 

TOKEN. L£X£ME_SI2£  ;=  L£XEME_COUNT ; 

IS_VALIO  :=  TRUE: 
exit: 
end  if: 

when  15  =>  if  ((CHHOLD  in  DIGITS_TYPE)  or  else 
(CH_H0L0  in  UPPER_CAS£_HEX)  or  else 
(CH_HOLD  in  LOWER_CASE_HEX ) )  then 
LEXEMECOUNT  :=  LEXEME_COUNT  +  1: 

TOKEN. LEXEME(LEXEME_COUNT)  CH_HOLD: 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_fILE,  CHHOLD): 
elsif  (CHHOLD  =  then 
STATE  16: 

L£XEME_COUNT  ;=  L£XEME_COUNT  +  1: 

TOKEN. LEXEME(LEX£ME_COUNT)  ;=  CH_HOLD: 

6£T_CHAR_P IPE . GET_CHARACTER( TEXT_F I LE ,  CH_HOLO ) ; 
elsif  (((CH_HOLD  =  ■#■)  and  (not  SHARP_REPLACEMENT) )  or 
else  ((CH_HOLO  =  ';•)  and  SHARP_REPLACEMENT ) )  then 
STATE  :=  18: 

LEXEME_COUNT  ;=  LEXEM£_COUMT  +  1: 

TOKEN. L£X£ME(LEXEME_COUNT)  ;=  CH_H0LD; 
GET_CHAR_PIP£.G£T_CHARACTER(T£XT_fILE,  CH_H0LD): 
else 

TOKEN. LEXEME_SIZE  ; =  L£XEME_COUNT : 

IS_VALID  :=  FALSE: 
exit: 
end  if: 

when  17  =>  if  (CHHOLD  =  '+')  then 
STATE  :=  6: 

LEXEME_COUNT  :=  LEXEME_COUNT  t  1: 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CH_HOLD: 
GET_CHAR_PIP£.GET_CHARACTER{TEXT_FILE.  CHHOLD); 
elsif  (CHHOLD  in  OIGITS_TYPE)  then 
STATE  :=  7; 

LEXEME_COUNr  :=  LEXEMt_COUNT  +  1; 

TOKEN. LEXEMt(LEXEME_COUNT)  CHHOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE,  CH  HOLD) ; 
e  1  se 

TOKEN. LEXEME_SIZE  : =  LEXEMECOUNT ; 

IS_VALI0  :=  FALSE; 
exit: 
end  if; 

when  18  =>  if  ((CH  HOLD  -  E')  or  else  (CHHOLD  =  'e'))  then 
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STATE  :=  4; 

LEXEME_COUNT  ;=  LEXEME_COUNT  +  1; 

TOKEN. LEXEHE(LEXEM£_COUNT)  CHHOLD; 
GET_CHAR_PIPE.GET_CHARACTER(TEXT_EILE,  CH_HOLD) ; 
elsif  ((CH_HOLD  in  UPPER_CASE_L£TTER)  or  else  (CH_HOLO  in 
LOUER_CASE_LETTER))  then 
TOKEN. LEXEME_SIZ£  :=  LEXEME_COUNT ; 

IS_VALIO  :=  FALSE; 
exit; 
else 

TOKEN. LEXEMESIZE  ;=  LEXEME_COUNT ; 

I S_ VALID  :=  TRUE; 
exit; 
end  if; 

when  others  =>  null; 
end  case; 
end  loop; 

elsif  {CH  =  '■')  then 

TOKEN. SOURCE .LINE_NUMB£R  ;=  LIN£_TOTAL; 

TOKEN. SOURCE. FILE_NAM£_SrZ£  ;=  T£XT_IO.nanie(T£XT_fILE)'LEN6TH; 

TOKEN. SOURCE .FILE_NAME( 1. . TEXTIO . name( TEXTf I LE )' LENGTH )  ;= 
TEXT_IO.name(TEXT_FIL£); 

TOKEN. LEX£ME(L£XEME_COUNT)  :=  CH; 

IS_VALIO  :=  TRUE; 
loop 

case  STATE  is 

•hen  1  =>  if  (CH_HOLD  in  CHAR_LI T_TYPE )  then 
STATE  :=  2; 

LEXEM£_COUNT  ;=  LEXEME_COUNT  +  1; 

TOKEN. LEXEME(LEXEM£_COUNT)  ;=  CH_H0LD; 

CH  :=  CH_H0LD; 

GET_CHAR_PIPE.GET_CHARACTER(TEXT_FILE,  CH_H0LD) ; 
else 

TOKEN. TOKEN_TYPE  ;=  DELIMITER; 

TOKEN. LEXEME_SIZE  ;=  LEXEME_COUNT ; 
exit; 
end  if; 

when  2  =>  if  (CH  HOLO  -  then 

TOKEN. TOKENTYPE  :=  CHARACTERLI T ; 

LEXEME_COUNT  :=  LEXEME  COUNT  <•  1; 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CHHOLO; 

TOKEN. LEXEMESIZE  ;=  LEXEMECOUNT ; 

GE  T  CHAR  P I  PE . GE  T_CHARACTER( TEX  T_F I LE .  CH  HOLD ) ; 
exit; 
else 

TOKEN. TOKENTYPE  ;=  DELIMITER; 

PARTIAL_T0KEN  ;=  TRUE; 

TOKEN. LEXEME(LEXEME_COUNT) 

TOKEN. LEXEME_SIZE  ;=  LEXEME_COUNT  -  1; 

1  L  ; 
end  t  f  ; 
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»hen  others  =>  null; 
end  case: 
end  loop; 

elsif  ((CH  =  '&')  or  else  (CH  =  '(')  or  else  (CH  =  ')')  or  else 
(CH  =  ’•')  or  else  (CH  =  '+')  or  else  (CH  =  or  else 

(CH  =  or  else  (CH  =  or  else  (CH  =  ’/')  or  else 

(CH  =  or  else  (CH  =  or  else  (CH  =  ’<’)  or  else 

(CH  =  '=')  or  else  (CH  =  '>')  or  else  (CH  =  '!')  or  else  (CH  =  '!'))  then 

TOKEN. TOKENTYPE  :=  DELIMITER; 

TOKEN. SOURCE. LINENUMBER  :=  LINE_T0TAL; 

TOKEN.  SOURCE.  E I  LE_NAME_SIZE  ;=  TEXT_I0 .  na(ne(  TEXT_F  I LE  )' LENGTH ; 

TOKEN. SOURCE. F I LE_NAME( 1. . TEXT_IO . narae( TEXT_FIL£ )’ LENGTH )  := 
TEXT_IO.name(TEXT_FILE) ; 

IS_VALID  :=  TRUE; 

TOKEN. LEXEME(LEXEME_COUNT)  ;=  CH; 
case  CHHOLD  is 

■hen  =>  if  (CH  =  then 

LEXEME_COUNT  ;=  LEXEME_COUNT  +  1; 

TOKEN. LEXEM£(LEXEME_COUNT)  :=  CHHOLD; 

GETCHARPIPE .G£T_CHARACTER(T£XT_FILE,  CH_HOLD) ; 
end  if; 

when  ->  if  (CH  =  '•')  then 

LEXEME  COUNT  ;=  LEXEME_COUNT  +  1; 

TOKEN. LEXEME(lEXEME_COUNT)  ;=  CH_H0LD: 

GET_CHAR_PIP£ .G£T_CHARACTER(TEXT_FIL£,  CH_H0LD) ; 
end  if; 

when  =>  if  ((CH  =  ';•)  or  else  (CH  =  '/')  or  else  (CH  =  '>')  or 
e 1 se  (CH  =  '  < ' ) )  then 

LEXEME_COUNT  :=  LEXEM£_COUNT  t  1; 

TOKEN. LEXEM£(LEX£ME_COUNT)  ;=  CH_HOLD; 
GEr_CHAR_PIP£.GET_CHARACT£R( T£XT_FILE,  CH_HOLD); 
end  if; 

when  >’  =>  if  ((CH  =  '<')  or  else  (CH  =  ’>')  or 
else  (CH  =  ' =' ) )  then 

LEXEME_COUNT  :=  LEX£ME_COUNT  ►  1; 

TOKEN. LEXEME(LEXEME_COUNT)  CH_HOLD; 

GET  CHAR  PIPE .GET_CHARACTER( TEXT_FILE .  CH  HOLD) ; 
end  if; 

when  '<'  =>  if  (CH  =  '<')  then 

LEXEME_COUNT  LEXEMECOUNT  *  1; 

TOKEN. LEXEME(LEXEME_COUNT)  :=  CHHOLD; 

GET  CHAR  PIPE .GET_CHARACTER( TEXT  FILE  ,  CH  HOLD) ; 
end  if; 

when  =>  if  (CH  =  '-')  then 

TOKEN . lOKENTYPE  ;=  COMMENT ; 

LEXEME  COUNT  ;=  LEXEMECOUNT  t  1; 

TOKEN. LEXEME(LEXEME_C0UNT)  :=  CHHOLD; 

GET  CHAR  PIPE .GET_CHARACTER( TEXT  FILE,  CHHOLD) ; 
while  ((CHHOLD  /=  ENDLINE)  and 
(CH  hold  /=  ENDFILE))  loop 

LEXEME  COUNT  LEXEME  COUNl  ^  1; 
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TOKEN, LEXEMt{LEXEME.COUNI)  CHHOLD; 
GET_CHAR_PIPE.GEI_CHARACr£R( rEXT_FILE,  CH_HOLD) ; 
end  loop; 
end  if; 

when  others  =>  null; 
end  case; 

TOKEN. LEXEME_SIZE  LEXEME_COUNr ; 
elsif  ((CH  =  or  else  (CH  =  'X'))  then 

TOKEN. TOKEN_TYPE  ;=  STRING_LIT; 

TOKEN. SOURCE. LINE  NUMBER  LINETOTAL; 

TOKEN. SOURCE .FILE_NAME_SI2E  ;=  TEXTIO . name( TEXT_F 1 LE )' LENGTH ; 

TOKEN. SOURCE . FILE_NAME( i . . TEXT  IO. name( TEXT_FILE )'  LENGTH)  ;  = 
TEXT_IO.name(TEXT_FILE); 

TOKEN. LEXEME(LEXEME_COUNT)  ;=  CH; 

OUOTE_REPLACEMENT  ;=  (CH  =  'X'): 
loop 

case  STATE  is 

when  1  O  if  (((CH_HOLO  =  •"■)  and  (not  OUOTEREPLACEMENT ) )  or  else 
{(CH_HOLD  =  "X')  and  OUOTEREPLACEMENT ) )  then 
STATE  ;=  2; 

LEXEME_COUNT  ;=  LEXEME_COUNT  *  1; 

TOKEN. LEX£ME(LEXEME_C0UNT)  ;=  CH_HOLD; 
GET_CHAR_PIP£.GET_CHARACTER(TEXT_F11  E.  CH  HOLD); 
elsif  (CH_H0LD  in  CHAR_LIT_TYPE )  then 

if  ((OUOT£_R£PLACEMENT  and  (CH_HOLD  /=  'X'))  or  else 
( (not(OUOTE_R£PLACEM£NT) )  and  (CH_H0LD  /=  '“')))  then 
STATE  ;=  4; 

LEXEME_COUNT  ;=  LEX£ME_COUNT  +  1; 

TOKEN. LEXEME(LEX£M£_COUNT)  ;=  CH_H0LD; 
G£T_CHAR_PIPE.GEI_CHARACTER(TEXT_FILE ,  CH_HOLD) ; 
else 

TOKEN. LEXEME _S1ZE  ;=  LEXEME _COUNT ; 

IS_VALID  ;=  FALSE; 
exit; 
end  if; 
else 

TOKEN. LEXEME^SIZE  :=  LEXEME^COUNT ; 

ISVALIO  :=  FALSE; 
exit; 
end  i  f  ; 

when  2  =>  if  (((CHHOLD  ^  ■"')  and  (not  OUOTEREPLACEMENT ) )  or  else 
((CH  HOLD  =  'X’)  and  OUOTEREPLACEMENT ) )  then 
STATE  ;=  3; 

LEXEMECOUNT  ;=  LEXEMECOUNT  +  1; 

TOKEN. LEXEME(LEXEM£_C0UNT)  ;=  CHHOLD; 

GETCHARPIPE  GE TCHARACTE R( TEXTF I LE ,  CHHOLD) ; 
e  I  so 

TOKEN. LEXEMESIZF  ;=  LEXEMECOUNT ; 

ISVALIO  TRUE; 
exit; 
end  t  f  ; 
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when  3  O  if  (((CH_H0LD  =  •"')  and  (not  0UOTE_R£PL/>C£MENr ) )  or  else 
((CH_H0L0  =  •%')  and  OUOIE_REPLACEM£NT) )  then 
LEXEME  COUNT  LEXEME_COUNr  <■  1; 

TOKEN. LEXEME (LEXEME_COUNT)  ;=  CR^HOLD; 

TOKEN. IEXEME_SI2E  :=  LEXEM£_COUNT ; 

GET  CHAR  PIPE  ,GET_CHARACT£R(  TEXT  FRE  ,  CH_HOLO)  ; 
exit: 

els1f  (CH_HOLO  in  CHAR^LITTYPE)  then 

if  ((QUOT£_fi£PLACeM£MT  and  (CH_HOLO  /-  '»')>  or  else 
((not(OUOT£_REPLACEMENT))  and  (CHhOLD  /=  '*•)))  then 
STATE  ;=  4; 

L£X£ME_COUNT  ;=  LEXEME^COUNT  +  1; 

TOKEN. LEXEM£(LEXEME_C0UMT)  ; -  CHHOLD; 
GET_CHAR_PrPE.GET_CHAflACT£R(T£XT_FILE.  CH_HOLD) ; 
else 

TOKEN. LEXEME_SI2£  ; -  L£X£ME_COUNT ; 

IS_VALI0  ;=  FALSE; 
exit; 
end  if; 
else 

TOKEN. LEX£ME_SIZE  L£XEM£_COUNT ; 

IS_VALID  :=  FALSE; 
exit; 
end  if; 

when  4  =>  if  (({CH_HOLD  =  and  (not  0UOTE_REPLACEMENT) )  or  else 

((CH_H0L0  =  ■<’)  and  0UOTE_REPLAC£HENT ) )  then 
STATE  ;=  2; 

LeXEM£_COUNT  :=  LEXEME_COUNT  +  1; 

TOKEN. LEXEME (LEXEME^COUNT)  ; =  CH_HOLO; 
GET_CHAR_PIPE.6£T_CHARACT£R(T£XT_FILE,  CH_H0L0); 
elsif  (CH_HOLO  in  CHAR_LI I_TYP£ )  then 

if  ((QUOTE_R£PLAC£M£NT  and  (CH_H0LD  /=  ’X'))  or  else 
((not('3UOT£_R£PLACEMENT))  and  (CH_H0LD  /=  "’ '  ) ) )  then 
LEXEME_COUNT  ; =  lEXEME_COUNT  +  1; 

TOKEN. L£XEME(L£XEME_COUNT)  :=  CH_HOLD; 

GET_CHAR_P1PC .GET_CHAHACTEH(TEXT_FILE.  CH_HOLO) ; 
e  I  se 

TOKEN. LEXEME_SIZ£  ; -  LEXEME^COUNT ; 

IS_VALID  :=  FALSE; 
exit; 
end  if; 
e  1  se 

TOKEN. LEXEMESIZE  :=  LEXEMECOUNT ; 

1S_VALID  ;=  FALSE, 
exit; 
end  if; 

wnen  others  ->  null; 
end  case; 
end  loop: 

elsif  (CH  -  ENDFILE)  then 
lOKf N , lOKi N  ryPE  : -  fOI ; 
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TOKEN. SOURCE. LINENUMBER  ;=  LINETOTAL; 

TOKEN. SOURCE. FILE_NAME_SI2E  :=  TEXT_IO . name( TEXT_F ILE )' LENGTH ; 
TOKEN . SOURCE . F ILE_NAME ( 1 . . TEXT_IO . name( T£XT_F ILE ) ' LENGTH )  : = 
TEXT_IO.name(TEXT_FILE): 

TOKEN. LEXEME(LEXEME_COUNT )  CH; 

TOKEN. LEXEME_SIZE  :=  LEXEMECOUNT; 

IS_VALID  ;=  TRUE; 

else  --  character  is  not  defined  in  ADA 
TOKEN. TOKEN_TYPE  :=  UNOEFCHAR; 

TOKEN. SOURCE. LINENUMBER  LINE_TOTAL; 

TOKEN. SOURCE. FILE_NAME_SIZE  :=  IEXT_l0.name( TEXIFILE )' LENGTH; 
TOKEN. SOURCE. FI L£_NAME( t . . TEXT_IO.name( TEXT_F ILE )' LENGTH)  := 
TEXT_IO.name(T£XT_FILE); 

TOKEN. LEXEME(LEX£ME_COUNT)  CH; 

TOKEN. LEXEME_SIZE  :=  LEXEMECOUNT ; 

IS_VALI0  :=  FALSE; 
end  if; 

end  GETTQKEN; 
end  BU1LD_T0KEN_PIP£; 

function  VALIO_COMMENT( TOKEN  ;  in  TOK£N_RECORD_TYPE )  return  boolean  is 
--  pre  -  TOKEN  is  a  comment. 

--  post  -  if  the  leteme  of  the  comment  contains  at  least  one  letter  or 
digit  then  VALIO_COMMENT  is  true,  else  VALIO_COMMENT  is  false. 


subtype 

UPP£R_CASE_LETTER 

IS 

character 

range 

■A'  . 

.  'Z' 

subtype 

LOWER_CASE_LETTER 

is 

character 

range 

'  a '  . 

subtype 

OIGITS_TYPE 

is 

character 

range 

■0'  . 

.  '9' 

IS_VALI0  :  boolean  :=  FALSE; 

LEX£ME_CQUNT  ;  positive  3'. 
begin 

while  ((not  IS_VALID)  and  (LEXEM£_COUNT  <=  TOKEN , LEXEME_S1 ZE ) )  loop 
IS_VALI0  ;=  ((TOKEN. LEXEM£(LEXEME_COUNT)  in  UPPER_CASE_LETTE R )  or  else 
(TOKEN. LEXEME(LEXEME_COONT)  in  LOWER_CASE_LETTER )  or  else 
(TOKEN. LEXEME(LEX£ME_COUNT)  in  DIGI TS_TYPE ) ) ; 

LEXEME_COUNT  L£X£ME_COUNT  ♦  1; 
end  loop: 
return  IS_VAHD; 
end  VALID_COMMENT; 

procedure  SET_UP_TOKEN_SCANNER( PARSE_f ILE  ;  in  TEXTIO. f i le_type)  is 
--  pre  '  must  be  called  before  any  other  procedure  in  the  TOKEN_ 

SCANNER  module,  only  one  file  may  be  set  up  at  a  time. 
PARSEFILE  must  be  open  and  rewound  before  TOKENSCANNER 
can  be  set  up . 

ISVALIO  :  boolean: 
beg  i  n 

LINETOTAL  :=  1; 

COMMENT_TOTAL  0; 

BU1LD_T0KEN_P1PE . INI T 1 AL I ZE_ TOKEN  P I  PE ; 

BUILD_TOKEN_PIPE.GET  TOKEN(PARSE  FILE.  NEXT  TOKEN,  IS_ZALID); 
while  (IS  VALID  and  (( NE X T  lOKEN . TOKEN  lYPE  -  SEPARATOR)  or  else 
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{NEXrrOKEN. rOKEN_TYPE  =  COMMENT)))  loop 
if  (NEXT_TOKEN.TOKEN_TYPE  =  COMMENT)  then 
if  (VALID_COMMENT(NEXT_rOKEN))  then 
COMMENT  TOTAL  :=  COMMENT  TOTAL  *■  1; 
end  if; 
end  if; 

BUILD_TOKEN_PIPE.GET_TOKEN(PARSE_FlLE.  N£XT_TOKEN.  IS_VALID); 
end  loop; 

if  (IS_VALIO)  then 
CONSUME_TOKEN(PARSE_FILE ) ; 
e  I  se 


case  (NEXT_TOKEN.TOKEN_TYPE) 
when  IDENTIFIER  raise 

when  NUMERIC_LIT  =>  raise 

when  STRING_LIT  =>  raise 

when  UNDEFCHAR  =>  raise 

when  others  =>  null; 


IS 

ILLEGALIDENTIFIER; 

ILLEGAL_NUMERIC_LIT 

ILLEGAL_STRING_LIT; 

ILLEGAL_CHARACTER; 


end  case; 


end  if; 


end  SET_UP_TOKEN_SCANNER; 


procedure  R£LEASE_TOKEN_SCANNER( PARSE_FILE  :  in  out  TEXTIO . f i 1 e_type )  is 
--  pre  -  TOKEN_SCANNER  has  been  set  up. 

--  post  -  All  TOKEN_SCANNER  interfaces  are  undefined  with  the  exception  of 

SET_UP_TOKEN_SCANNER.  The  TOKEN_SCANNER  must  be  released  prior  to 
main  program  termination,  PARSE_FILE  is  closed. 

beg  1  n 

TEXTJO.close(PARS£_fILE); 
end  REL£ASE_TOK£N_SCANNER; 


procedure  LOOK_TOK£N( PARS£_FILE  ;  in  T£XT_IO . f i 1 e_type ; 

TOKEN  ;  out  TOK£N_RECORD_TYPE )  is 

--  pre  -  scanner  has  been  set  up  and  an  exception  has  not  occurred. 

--  post  -  TOKEN  contains  the  token  under  the  read  head  in  PARSE_FILE. 
The  scanner  filters  out  comments  and  separators. 

beg  ill 

TOKEN  CURRENT_TOKEN ; 
end  l.OOK  TOKEN; 

procedure  LOOK_AHEAD_TOKEN( PARSE_F ILE  ;  in  TEXT_IO . f i 1 e_type ; 

TOKEN  ;  out  TOKEN_RECORO_TYPE )  is 

-  post  -  TOKEN  contains  the  next  token  to  come  under  the  read  head  in 
PARSEFILE.  The  scanner  filters  out  comments  and  separators. 

begin 

TOKEN  :=  NEXT_TOKEN; 
end  100K_AHEAD_T0KEN; 


procedure 

pre 

post  - 


CONSUME_TOKEN(PARSE_FILE  :  in  TEX T  10. f i le_type  )  is 
the  scanner  has  been  set  up. 

the  read  head  is  advanced  one  token  in  PARSEFILE. 
The  scanner  filters  out  comments  and  separators. 
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IS_VALIO  :  boolean: 

TEMP_TOKEN  :  T0KEN_REC0R0_TYPE ; 
begin 

CURRENT  TOKEN  ; -  NEXT_TOKEN: 
if  (NEXT_TOKEN.TOKEN_TYPE  /=  EOF)  then 

BUILD_TOKEN_PIPE.GET_TOKEN(PARS£_fILE,  TEMPTOKEN,  IS_VALI0); 
while  (IS_VALID  and  ( ( TEMPTOKEN . rOKEN_TYPE  -  SEPARATOR)  or  else 
(TEMP_TOKEN.TOK£N_TYPE  -  COMMENT)))  loop 
if  (TEMP_TOKEN.TOKEN_TYPE  =  COMMENT)  then 
if  (VALID_COMMENT(TEMP_TOK£N))  then 
COMMENTTOTAL  :=  COMMENTTOTAL  +  1; 
end  if; 
end  if; 

BUILD_TOKEN_PIPE.GET_TOKEN(PARSE_FILE.  TEMPTOKEN,  IS_VALID); 
end  loop; 

if  (not(IS_VALIO))  then 

case  (NEXT_TOKEN.TOKEN_TYPE)  is 

when  IDENTIFIER  =>  raise  ILLEGALIDENTIFIER; 

when  NUM£RIC_LIT  =>  raise  ILLEGAL_NUMERIC_LIT; 

when  STRIMG_LIT  =>  raise  ILL£GAL_STRING_LIT; 

when  UNOEFCHAR  =>  raise  ILLEGALCHARACTER; 

when  others  =  >  nul 1 : 

end  case; 
e  1  se 

N£XT_TOKEN  TEMP_T0K£N; 
end  if; 
end  if; 

end  CONSUM£_TOK£N; 

function  LINES_SCANNEO{PARSE_f ILE  :  in  TEXT_I0 . f i le_type )  return  positive  is 
--  post  -  returns  the  number  of  lines  in  PARS£_FIlE 

that  have  been  scanned  by  the  token  scanner. 

beg  i  n 

return  CURRENT_TOKEN . SOURCE . L INE_NUMBER; 
end  LINES_SCANNE0; 

function  COMMENTS_SCANNEO( PARSE_F ILE  :  in  TEXT_10 . f i 1 e_type ) 

return  natural  is 

--  pre  -  scanner  has  been  set  up. 

--  post  -  returns  the  number  of  "meaningful"  comments  in  PARSEFILE 

that  have  been  scanned  by  the  token  scanner.  A  "meaningful" 
comment  is  defined  as  a  comment  that  contains  at  least  one 
letter  or  digit. 

beg  1  n 

return  COMMENTTOTAL ; 
end  COMMENTSSCANNED; 

end  TOKEN  SCANNER; 
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APPENDIX  I 


”ADAFLOW”  PROGRAM  LISTING  -  GENERIC  PACKAGES 


TITLE; 

ADA FLOW 

;; 

MODULE  NAME; 

PACKAGE  GENERIC_LIST 

-- 

FILE  NAME; 

LIST.AOA 

— 

DATE  CREATED; 

31  MAR  88 

-- 

LAST  MODIFIED: 

28  APR  88 

-- 

AUTHOR! S) : 

LT  ALBERT  J.  GRECCO,  USN 

-- 

DESCRIPTION; 

This  package  defines  the  operations 
available  on  the  abstract  data  type  LIST. 

-- 

generic 

type  IT£M_TYPE  is  private; 
package  GENERIC_LIST  is 

type  LIST  is  limited  private; 

L1ST_OV£RFLOW  :  exception; 

LISTUNDERFLOW  ;  exception; 

--  Operations:  If  the  list  is  not  empty,  then  one  of  the  nodes  is  designated 
as  the  current  node.  Ocaas ional ly.  in  the  postcondition,  it  is  necessary 
to  refer  to  the  list  of  the  current  node  as  they  oere  immediately  before 
execution  of  the  operation.  L-pre  and  c-pre.  respectively,  are  employed 
for  these  references. 

procedure  FINO_FIRST(L  :  in  out  LIST); 

-  pre  -  The  list  L  is  not  empty. 

--  post  -  The  first  node  is  the  current  node. 

-  exceptions  raised  -  LISI_UNOtRf LOW  if  L  is  empty. 

procedure  fIN0_N£XT(L  in  out  LIST); 

-  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
-  post  -  c-next  in  L  is  the  current  node. 

-  exceptions  raised  -  L ISTUNDERFLOW  if  L  is  empty. 

-  LIST  OVERFLOW  if  the  last  node  is  the  current  node. 
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procedure  FIND_PREVIOUS( L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOU  if  L  is  empty  or  c  is  the  first  node. 

procedure  FIND_LAST(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

procedure  RETRIEVE(L  :  in  LIST;  ITEM  ;  out  ITEMTVPE); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOU  if  L  is  empty. 

procedure  UPOATE(L  :  in  out  LIST;  ITEM  :  in  ITEMTYPE); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  current  node  in  L  contains  ITEM  as  its  element. 

--  exceptions  raised  -  LISTUNOERFLOU  if  L  is  empty. 

procedure  INSERT(L  :  in  out  LIST;  ITEM  ;  in  ITEMIYPE); 

--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 

node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 

ITEM  is  the  current  node. 

--  exceptions  raised  -  LI ST_0VERFL0U  if  L  has  reached  its  bound. 


procedure  0ELETE(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node, 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LIST  UNOERFLOU  if  L  is  empty. 

function  SIZE_OF(L  :  in  LIST)  return  natural; 

--  post  -  SIZE_0F  is  the  number  of  nodes  in  list  L, 

function  EMPTY(L  :  in  LIST)  return  boolean; 

--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 


function  FULL(L  :  in  LIST)  return  boolean; 

--  post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 


function  FIRST(L  :  in  LIST 
--  pre  -  The  list  L  is  not 
--  post  -  If  the  first  node 
FIRST  IS  false. 

-  exceptions  raised  -  LIST 


)  return  boolean; 
empty , 

IS  the  current  node  in  L 
UNOERFLOU  if  L  is  empty. 


then  FIRST 


is  true, 


e  I  se 
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function  LAST ( L  ;  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  currant  node  in  L  then  LAST  is  true,  else 
LAST  IS  false. 

--  exceptions  raised  -  LlSTUNDERf LOU  if  L  is  empty. 

procedure  CREATEIL  ;  in  out  LIST;  SUCCESS  :  out  boolean); 

--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

procedure  DISPOSE(L  :  in  out  LIST); 

--  post  -  L-pre  does  not  exist. 

private 

type  LISTINSTANCE; 

type  LIST  is  access  L ISTINSTANCE : 

end  GENERIC_LIST; 

Kith  UNCHECKED_OEALlOCATION; 
package  body  GEMERICLIST  is 

type  NODE; 

type  NOOE_POINTER  is  access  NODE; 
type  NODE  is 
record 

ELEMENT  :  ITEM_TYPE; 

NEXT  ;  N00E_P0INTER: 
end  record; 
type  LISTINSTANCE  is 
record 

HEAD  :  N0DE_P01NTER  null; 

TAIL  :  NODE_POINTER  ;=  null; 

CURRENT  :  NOOE_POINTER  :=  null; 

SIZE  :  natural  :=  0; 
end  record: 

procedure  FREE_NODE  is  ne«  UNCHECKEO_OEALLOCAT10N( NODE ,  NODEPOINTER) ; 
procedure  FREE_LIST  is  new  UNCHECKEO_OEALLOCATION( L ISTINSTANCE ,  LIST), 

procedure  F1ND_F1RST(l  :  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

-  post  -  The  first  node  is  the  current  node. 

--  exceptions  raised  -  LIST  UNDERFLOW  if  L  is  empty, 
beg  in 

if  (EMPrY(L))  then 
raise  LISTUNDERFLOU; 
end  if; 

L. CURRENT  :=  L.HEAO: 
end  UNO  FIRST; 
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procedure  FIND_NExr(L  :  in  out  LIST)  is 

--  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
--  post  -  c-ne*t  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty. 

-  LISTOVERFLOW  if  the  last  node  is  the  current  node. 

begin 

If  (EMPTY(l))  then 
raise  LIST_UNDERFLOW; 
end  if; 

if  (LAST(l))  then 
raise  LIST_OVERf LOW; 
end  if; 

L. CURRENT  :=  L  .CURRENT .NEXT ; 
end  fIND_NEXT; 

procedure  FINO^PREVIOUS( L  ;  in  out  LIST)  is 

--  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty  or  c  is  the  first  node. 

TEMPPOINTER  :  NOOE_POINTER; 

begin 

if  (EMPTY(L)  or  FIRST(L))  then 
raise  LIST_UN0ERFL0W ; 
end  if; 

TEMP_POINTER  ;=  L.HEAD; 

while  (TEMP_POINTER.N£XT  /=  L. CURRENT)  loop 
TEMP_POINTER  :=  TEMP_POINTER . NEX T ; 
end  loop; 

L. CURRENT  :=  TEMP_POINTER; 
end  FINO_OREVIOUS; 

procedure  fIND_LAST(L  ;  in  out  LIST)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty, 
begin 

if  (EMPTY(L))  then 

raise  LIST_UN0ERFL0W; 
end  if; 

while  (not  LAST(L))  loop 
FINO_NEXT(L); 
end  loop; 
end  FIND_LAST; 

procedure  RETRIEVE(L  :  in  LIST;  ITEM  :  out  ITEMTYPE)  is 
pre  -  Ihe  list  L  is  not  empty. 

--  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LIST  UNUERtlOW  if  L  is  empty, 
beg  1  n 

if  (EMPTY(I  ))  then 

raise  LISI  UNDERKOW; 
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end  if; 

ITEM  1=  L. CURRENT .ELEMENT; 
end  RETRIEVE; 

procedure  UPDATE{L  ;  in  out  LIST;  ITEM  ;  in  ITEMTVPE)  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  Current  node  in  L  contains  ITEM  as  its  element. 

--  exceptions  raised  -  LISTUNDERFLOW  if  L  is  empty, 
begin 

if  (EMPTY(L))  then 
raise  LIST_UNOERFLOW; 
end  if; 

'■..CURRENT. ELEMENT  ITEM; 
end  UPDATE; 

procedure  INSERT(L  ;  in  out  LIST;  ITEM  ;  in  ITEMTYPE)  is 
--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  the  last  node  in  the  list,  and  the  last 
node  in  L-pre,  if  any,  is  its  predecessor.  The  node  containing 
ITEM  is  the  current  node. 

--  exceptions  raised  -  LISTQVERFLOW  if  L  has  reached  its  bound. 

TEMP  POINTER  ;  MOOE_POINTER ; 
begin 

if  (FULL(L))  then 
raise  LIST_0VERFL0W; 
end  if; 

TEMP_POINT£R  ;=  new  N00E'(ITEM,  null); 
if  ( L . HEAD  =  null)  then 
L.HEAO  :=  TEMP_POINTER; 

L.TAIL  ;=  TEMP_POINTER; 
else 

L.TAIL. NEXT  :=  TEMP_POINrER ; 

L  TAIL  ; =  TEMPPOINTER; 

end  if; 

L. CURRENT  :=  TEMPPOINTER; 

L.SIZE  :=  L.SIZE  +  1; 
end  INSERT; 

procedure  0ELETE(L  :  in  out  LIST)  is 
■-  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node, 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LIST_UNDERf LOW  if  L  is  empty. 

TEMP  POINTER  :  NOD£_POI NTER ; 
beg  i  n 

If  (EMPTYID)  then 
raise  LISTUNDERFLOW; 
end  1  f ; 

if  (I  .CURRENT  L.HEAO)  then 
(EMP  POINIER  :  L .HEAD: 
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while  (TEMP_POINTER.NEXT  L. CURRENT)  loop 
TEMP_POINTER  :=  TEMPPOINIER.NEXT; 
end  loop: 

TEMPPOINIER.NEXT  L . CURRENT , NEXT ; 
if  (L. CURRENT  =  L.TAIL)  then 
L.TAIL  :=  TEMPPOINTER; 
end  i f ; 
else 

if  (L.HEAD  =  L.TAIL)  then 
L.TAIL  :=  null; 
end  if; 

L.HEAD  L.HEAD. NEXT; 
end  if; 

FREE_NODE(L. CURRENT); 

L. CURRENT  ;=  L.TAIL; 

L.SIZE  :=  L.SIZE  -  1; 
end  DELETE; 

function  SIZE_OF(L  ;  in  LIST)  return  natural  is 
--  post  -  SIZE_0F  is  the  number  of  nodes  in  list  L. 
begin 

return  (L.SIZE); 
end  SIZE_0F; 

function  EMPTY(L  :  in  LIST)  return  boolean  is 

--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 

begin 

return  ( L , HEAD  =  null); 
end  EMPTY; 

function  FULL(L  :  in  LIST)  return  boolean  is 

--  post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

TEMP_POINTER  :  NOOE_POINTER ; 
begin 

TEMPPOINTER  :=  new  NODE; 

FREE_N00E( TEMPPOINTER); 
return  (FALSE); 
exception 

when  STORAGE  ERROR  => 
return  (TRUE): 
when  others  => 
raise; 
end  FULL; 

function  FIRSr(L  :  in  LIST)  return  boolean  is 

-  pre  -  The  list  L  is  not  empty. 

-  post  -  If  the  first  node  is  the  current  node  in  L  then  FIRST  is  true. 

FIRST  IS  false. 

exceptions  raised  IISI  UNDIRKOW  if  L  is  empty 


else 
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beg  1  n 

if  (EMPTY(L))  then 
raise  LIST_UNDERFLOW; 
end  if; 

return  (L. CURRENT  =  L.HEAD); 
end  FIRST; 

function  LAST(L  ;  in  LIST)  return  boolean  is 
--  pre  -  The  11st  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LAST  IS  false. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty, 
begin 

if  (EMPTY(L))  then 
raise  LISTUNOERFLOW; 
end  if; 

return  (L. CURRENT  =  L.TAIL); 
end  LAST; 

procedure  CREAT£(L  :  in  out  LIST;  SUCCESS  :  out  boolean)  is 
--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
is  TRUE  else  SUCCESS  is  FALSE. 

begin 

L  ;=  new  LIST_INSTANCE ' ( null ,  null,  null,  0); 

SUCCESS  :=  TRUE: 
exception 

when  ST0RAGE_ERR0R  => 

SUCCESS  ;=  FALSE; 
when  others  => 
raise: 
end  CREATE; 

procedure  0ISP0SE(L  ;  in  out  LIST)  is 
--  post  -  L-pre  does  not  exist, 
begin 

if  (not  EMPTY(L))  then 
FIND_LAST(L); 
while  (not  EMPTY(L))  loop 
DELETE(L) ; 
end  loop; 
end  if; 

FREE_LIST(L )  ; 
end  DISPOSE; 

end  GENERIC_LISf ; 
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TITLE  : 

ADA FLOW 

MODULE  NAME; 

PACKAGE  ORDEREO_GENERIC_LISI 

-- 

FILE  NAME: 

ORO_LIST.ADA 

-- 

DATE  CREATED: 

18  APR  88 

-- 

LAST  MODIFIED: 

28  APR  88 

-- 

AUTHOR(S); 

LT  ALBERT  J.  GRECCO.  USN 

-- 

DESCRIPTION: 

This  package  defines  the  operations 
available  on  the  abstract  data  type  LIST. 

— 

generic 

type  ITEMTYPE  is  private; 
package  ORDERED_GEN£RIC_LIST  is 

type  LIST  is  limited  private: 

LI ST_OVERFLOW  :  exception; 

LISTUNDERELOW  ;  exception ; 

--  Operations:  If  the  list  is  not  empty,  then  one  of  the  nodes  is  designated 
as  the  current  node.  Ocaas iona I ly ,  in  the  postcondition,  it  is  necessary 
to  refer  to  the  list  of  the  current  node  as  they  were  immediately  before 
execution  of  the  operation,  L-pre  and  c-pre.  respectively,  are  employed 
for  these  references. 

procedure  FINO_FIRST(L  ;  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  first  node  is  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

procedure  FINO_NEXT(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  last  node  is  not  the  current  node. 
--  post  -  c-next  in  L  is  the  current  node. 

--  exceptions  raised  -  LISTUNDERF LOW  if  L  is  empty. 

-  LISTOVERFlOW  if  the  last  node  is  the  current  node. 

procedure  FIN0_PREV10US(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  I  1ST  UNDERFLOW  if  L  is  empty  or  c  is  the  first  node. 

procedure  FIN0_LAST(L  ;  in  out  LIST); 

-  pre  -  The  list  L  is  not  empty 
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--  post  -  The  last  node  in  L  is  the  current  node. 

--  e«ceptions  raised  -  L ISr_UNDERFLOU  if  L  is  empty. 

procedure  RETRIEVE(L  :  in  LIST;  ITEM  :  out  ITEM_rYPE); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LIST_UNDERFLOW  if  L  is  empty. 

procedure  UPDATE(L  :  in  out  LIST;  ITEM  ;  in  ITEMTYPE); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  The  current  node  in  L  contains  ITEM  as  its  element. 

--  exceptions  raised  -  LIST_UNOERf LOW  if  L  is  empty. 

procedure  INSERT(L  :  in  out  LIST;  ITEM  :  in  ITEM_TYPE;  KEY  ;  in  positive); 
--  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound. 

--  post  -  A  node  containing  ITEM  is  in  the  list  in  ascending  order 

specified  by  KEY.  The  node  containing  ITEM  is  the  current  node. 
--  exceptions  raised  -  LISTOVERFLOW  if  L  has  reached  its  bound. 


procedure  DELET£(L  :  in  out  LIST); 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node, 

then  c-naxt.  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  is  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LIST_UMOERf LOW  if  L  is  empty. 


function  SIZE_0F(L  ;  in  LIST)  return  natural; 

■-  post  -  SIZ£_Of  is  the  number  of  nodes  in  list  L. 


function  EMPTY{L  ;  in  LIST)  return  boolean; 

•-  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 


function  FULL(L  :  in  LIST)  return  boolean; 

post  -  If  the  number  of  nodes  in  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 


function  fIRST(L  :  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  first  node  is  the  current  node  in  L  then  FIRST  is  true,  else 
FIRST  IS  false. 

--  exceptions  raised  ■  LISTJJNOERF LOW  if  L  is  empty. 


function  LASI(L  :  in  LIST)  return  boolean; 

--  pre  -  The  list  L  is  not  empty. 

-  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LASf  is  false. 

-  exceptions  raised  -  LIST  UNDERFLOW  if  L  is  empty. 
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procedure  CREATE(L  :  in  out  LIST;  SUCCESS  :  out  boolean): 

--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
IS  TRUE  else  SUCCESS  is  FALSE. 

procedure  DISPOSE(L  :  in  out  LIST); 

--  post  -  L-pre  does  not  exist. 

private 

type  LISTINSTANCE : 

type  LIST  Is  access  L I STINSTANCE ; 

end  ORDEREO_GENERIC_LIST; 


with  UNCHECKED 

.DEALLOCATION; 

package  body  0R0ERED_GENE RIC_ 

LIST  IS 

type  NODE; 

type  NOOE_PQINTER  is  access 

NODE  ; 

type  NODE  is 

record 

KEY 

positive: 

ELEMENT 

ITEMTYPE ; 

NEXT 

NODE^POINTER; 

end  record 

type  LIST_INSTANCE  is 

record 

HEAD 

NODE. POINTER 

:  -  null 

tail 

N0Dt_P01NTER 

; =  null 

CURRENT 

N00E_P0INrER 

:  -  null 

SIZE 

natural  ; ^  0 : 

end  record 


procedure  FREE  NODE  is  ne*  UNCHECKEO  DEALLOCAT ION( NODE ,  N0DE_ POI NTE R  ) : 
procedure  FREE_LIST  is  ne»  UNCHECKED_OEALLOCATION(LIST_INSTANCE ,  LIST); 

procedure  F1ND_FIRST(L  ;  in  out  LIST)  is 
pre  -  The  list  L  is  lot  empty. 

-  post  The  first  node  is  the  current  node 
--  exceptions  raised  -  L I  ST  UNDERFLOW  if  L  is  empty, 
begin 

if  (tMPTy(L))  then 
raise  L I  ST  UNDE Rf LOW : 

end  if; 

L .CURRENI  : -  L .HEAD: 
end  fINDFIHST; 

procedure  EIND  Ntxl(l  in  out  llSl)  is 

pre  -  The  list  l  is  not  empty  and  the  last  node  is  not  the  current  node, 
post  -  c-next  in  I  is  the  current  node, 
exceptions  laised  llsl  UNUl Rl l OW  it  i  is  empty. 
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-  LISTOVERFLQW  >f  the  last  node  is  tne  current  node. 

deg  1  n 

if  (EMPTY{L))  then 
raise  LIST_UN0ERFL0W: 
end  if: 

1  f  ( LAST (Li)  then 
raise  LIST^OVERFLOW; 
end  if; 

L. CURRENT  :=  L. CURRENT. NEXT: 
end  FINONEXT; 

procedure  F IN0_PRE'i/I0US(  L  :  in  out  LIST)  is 

-  pre  -  The  list  L  is  not  empty  and  the  first  node  is  not  the  current  node. 

--  post  -  c-prior  in  L  is  the  current  node. 

--  exceptions  raised  -  LIST  UNOERFLOVI  if  L  is  empty  or  c  is  the  first  node. 

TEMPPOINTER  :  NOOEPOINTER: 

begin 

if  (£MPTV(L)  or  flRST(L))  then 
raise  LIST _UN0ERFL0W : 
end  1 f : 

TEMP_PQINT£R  ; =  L.HEAO; 

while  ( rEMP_POINr£R.N£xf  /=  L. CURRENT)  loop 
T£MP_POINTER  :=  TEMP_P0I NTER . NEX T ; 
end  loop; 

L. CURRENT  :s  TEMP  POINTER; 
end  FIND_PREVIOUS: 

procedure  FIND_LAST(l  :  in  out  LIST)  is 
--  pre  -  The  list  l  is  not  empty. 

--  post  -  The  last  node  in  L  is  the  current  node. 

--  exceptions  raised  -  L I STUNDERE LOW  if  L  is  empty, 
beg  i  n 

if  (EMPTY(l))  then 
raise  LIST_UNDERFLOW: 
end  if; 

while  (not  LAST(L))  loop 
FIND_NEXT{ L ) ; 
end  loop: 
end  FINDLAST; 

procedure  RETRIEV£(L  in  LISl;  ITEM  :  out  ITEM_TYPE)  is 

-  pre  -  The  list  L  is  not  empty. 

-  post  -  ITEM  contains  the  value  of  the  element  in  the  current  node. 

--  exceptions  raised  -  LISTUNOERE LOW  if  L  is  empty. 

beg  1  n 

if  (EMPrY(L))  then 

raise  LIST  UNDERFLOW; 
end  if; 

I TEM  :  =  L  .CURRENT .ELEMENT : 
end  RETRIEVE ; 
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proctfdure  UPDATE(L  ;  in  out  LIST;  ITEM  :  in  ITEMTYPE)  is 
--  pie  -  The  list  L  IS  not  empty. 

-  post  -  The  current  node  in  L  contains  ITEM  as  its  element, 
exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

beg  1  n 

if  (EMPTY{L))  then 
raise  LIST_UNDERFLOW; 
end  if; 

L, CURRENT. ELEMENT  ;=  ITEM; 
end  UPDATE; 

procedure  1NSERT(L  :  in  out  LIST;  ITEM  :  in  ITEM_TYPE;  KEY  :  in  positive)  is 

-  pre  -  The  number  of  nodes  in  L  has  not  reached  its  bound, 
post  -  A  node  containing  ITEM  is  in  the  list  m  ascending  order 

specified  by  KEY.  The  node  containing  ITEM  is  the  current  node, 
exceptions  raised  -  LISTOVERFLOU  if  L  has  reached  its  bound. 

TEMP  pointer  :  NOOE_POI NTER ; 

SEARCHPOINTER  ;  NOOE_POINTEfl ; 
beg  I  n 

if  (FULL(L))  then 

raise  LIST_OVERFLQU: 
end  i  f ; 

TEMP_POINTER  :=  new  NODE'(KEY.  ITEM,  null); 
if  (L.HEAO  X  null)  then 
L.HEAD  ;=  TEMP_POINTER; 

L.TAIL  :=  TEMP_POINTER: 
else 

if  (L.HEAD. KEY  >  KEY)  then 
TEMP_POINTER.NEXT  :=  L.HEAD; 

L.HEAO  ;=  TEMP^POINTER; 
e  1  se 

SEARCH_POINTER  :=  L.HEAD. NEXT; 

If  (SEARCHPOINTER  /=  null)  then 
if  (SEARCHPOINTER.KEY  )  KEY)  then 
TEMP_POINTER.N£XT  :=  SEARCH_POINTER ; 

L.HEAO  NEXT  ;=  TEMPPOINTER; 
el  se 

while  ( (SEARCHPOINTER.NEXI  /=  null)  and  then 
(SEARCHPOINTER  NEXT. KEY  <  KEY))  loop 
SEARCHPOINTER  :=  SEARCH  POINTER . NE X T ; 
end  loop, 

TEMP  POINTER. NEXT  :=  SE ARCHPOI N TER . NE X T ; 

SEARCH  POINTER. NEXT  ;=  lEMP  POINTER; 

If  (SEARCH  POINTER  =  L.TAU)  then 
L.TAII  :=  TEMP_POINTER; 
end  1 f : 
end  if; 
else 

L.HEAO.NEXI  :=  I EMPPOl NTE R ; 

L.TAU  :=  TEMP  POINTER; 
end  if; 
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end  if; 
end  if; 

L. CURRENT  :=  FEMPPOINIER ; 

L  .SIZE  :  =  L  .SIZE  *•  1 ; 
end  INSERT; 

procedure  DELETE(L  ;  in  out  LIST)  is 
pre  -  The  list  L  is  not  empty. 

--  post  -  c-pre  in  not  in  the  list  L.  If  c-pre  was  the  first  node, 

then  c-next,  if  it  exists,  is  the  successor  of  c-prior.  If  the 
list  L  IS  not  empty,  then  the  last  node  is  the  current  node. 

--  exceptions  raised  -  LISTUNOERFLOW  if  L  is  empty. 

TEMPPOINTER  :  NOUEPOINTER; 
begin 

if  (EMPTY(L))  then 
raise  LIST  UNDERFLOW; 
end  i f  ; 

if  (L. CURRENT  /=  L.HEAD)  then 
TEMP_POINTER  : =  L.HEAD; 

while  (TEMP  POINTER. NEXT  /-  L. CURRENT)  loop 
TEMP_POINTER  :=  TEMP_P0I NTER . NEXT ; 
end  loop; 

TEMP_POINTER.N£XT  L . CURRENT . NEXT . 
if  (L. CURRENT  =  L.TAIL)  then 
L.TAIL  ;=  TEMPPOINTER; 
end  if; 
e1  se 

if  (L.HEAD  •-  L.TAIL)  then 
L.TAIL  : -  null; 
end  if; 

L.HEAD  ;=  L.HEAD, NEXT; 
end  1  f ; 

FREE_N00E(L. CURRENT); 

L. CURRENT  :=  L.TAIL; 

L.SIZE  ;=  L.SIZE  -  1; 
end  DELETE; 

function  SIZE_OT(l  ■  in  LIST)  return  natural  is 
--  post  -  SIZE  OF  IS  the  number  of  nodes  in  list  L. 
begin 

return  (L.SIZE); 
end  SI ZEOF ; 

function  EMPTY(L  :  in  LIST)  return  boolean  is 

--  post  -  If  the  list  L  has  no  nodes  then  EMPTY  is  true,  else  EMPTY  is 
false. 

beg  1 M 

return  ( L . HEAD  ^  null); 
end  LMPTY; 
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function  FULL(L  :  in  LIST)  return  Boolean  is 

--  post  -  If  tPe  numoer  of  nodes  m  the  list  L  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

TEMPPOINTER  :  NOOE_POI NTER ; 
begin 

TEMPPOINTER  :=  new  NODE; 

FREE_NOOE( TEMP_POINTER) ; 
return  (FALSE); 
exception 

when  STORAGE^ERROR  => 
return  (TRUE): 
when  others  -> 
raise; 
end  FULL: 

function  FIRST(L  ;  in  LIST)  return  boolean  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  first  node  is  the  current  node  m  L  then  FIRST  is  true,  else 
FIRST  IS  false. 

--  exceptions  raised  -  L I S I  UNDERFlOW  if  L  is  empty, 
beg  HI 

if  (EMPTY(l))  then 
raise  LIST_UNOERf LOW , 
end  if; 

return  (L. CURRENT  =  L.HEAD); 
end  FIRST; 

function  LASr(L  :  in  LIST)  return  boolean  is 
--  pre  -  The  list  L  is  not  empty. 

--  post  -  If  the  last  node  is  the  current  node  in  L  then  LAST  is  true,  else 
LAST  IS  false. 

--  exceptions  raised  -  L ISr_UNOERf LOW  if  L  is  empty, 
beg  1 M 

if  (EMPrf(L))  then 
raise  L I STUNDERFLOW ; 
end  if; 

return  (L, CURRENT  =  L.TAIL); 
end  last ; 

procedure  CR£ATE(L  in  out  LIST;  SUCCESS  ;  out  boolean'  is 
--  post  -  If  a  list  L  can  be  created  then  L  exists  and  is  empty,  and  SUCCESS 
IS  TRUE  else  SUCCESS  is  FALSE. 

beg  1  n 

L  new  L  1  STINSTANCE  ’  (  nu  I  1  .  null,  null,  0); 

SUCCESS  :=  TRUE; 
except  ion 

when  STORAGE  ERROR  => 

SUCCESS  -.  =  FALSE; 
when  others  => 
ra  1  se ; 
end  (.KFAIL  ; 
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procedure  DISP0SE(L  :  in  out  LIST)  is 
--  post  -  L-pre  does  not  exist. 

Peg  111 

if  (not  EMPTY(L))  then 
HND_LAST(  L  )  ; 
while  (not  EMPTy(L))  loop 
OELETE(L); 
end  loop: 
end  i f : 

FREE_LIST(L|; 
end  DISPOSE : 

end  ORDERED_GENERIC_LIST; 
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-- 
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-- 

OESCRIPIION: 

This  package 

defines  the  operations 

-- 

available  on 

the  abstract  data  type  STACK. 

•  •  •  .  . 

gener  1  c 

type  IT£M_ryP£  is  private: 
package  G£NERIC_STACK  is 

type  STACK  IS  limited  private; 

STACK_0VERFL0W  ;  exception; 

STACK_UNDERFL0W  ;  exception; 

procedure  POP(S  ;  in  out  STACK;  HEM  :  out  ITEM  TYPE); 

■■  pre  -  The  stack  S  is  not  empty, 

post  -  ITEM  contains  the  most  recently  arrived  element  of  S-pre. 
S  no  longer  contains  ITEM. 

--  exceptions  raised  -  STACKUNOERF LOW  if  S  is  empty. 

procedure  rOP(S  :  in  STACK;  ITEM  :  out  ITEMTYPE); 
pre  Ihe  stack  S  is  not  empty 

post  IlEM  contains  the  most  recently  arrived  element  of  Spre. 
exceptions  raised  STACKUNOf RFLOW  if  S  'S  empty. 

Uioceduie  PUSH! S  in  out  STACK;  IIEM  in  ITEM  TYPE); 
pre  Ihe  sire  of  S  has  not  reached  us  bound, 

post  b  lie  hides  ITEM  as  Us  most  recently  arrived  element. 
e>:.jptioris  raised  STACK  OVERFLOW  if  S  has  reached  its  bound. 


Oust 


i MP ' u  b  in  blAcK)  return  boolean; 

!f  the  stack  S  has  no  ITEMS  then  EMPTY  is  true,  else  EMPTY  is 
false 


*  Li  n  I. 


1  O'l 


p 


>)  •>  f 


in  SIACK)  return  Doclean; 

It  the  t»ijmber  of  !  U  MS  ui  the  stack  S  has  reached  the  maximum 
df'owed.  then  Futl  is  Hue.  else  HJLl  is  false. 
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procedure  CREATE(S  :  in  out  STACK;  SUCCESS  :  out  boolean); 

--  post  -  If  a  stack  S  can  be  created  then  S  exists  and  is  empty,  and  SUCCESS 
IS  TRUE  else  SUCCESS  is  FALSE, 

procedure  D1SP0SE(S  :  in  out  STACK); 

--  post  -  S-pre  does  not  exist. 

private 

type  NODE ; 

type  STACK  IS  access  NODE; 

end  GENERIC_STACK; 

with  UNCHECKED_0EALL0CATI0N; 
package  body  GENERICSTACK  is 

type  NODE  is 
record 

ELEMENT  :  ITEMTYPE, 

NEXT  ;  STACK; 
end  record; 

procedure  FHE£_NOOE  is  new  UNCHECKED_DEALLOCATION(NODE ,  STACK); 

procedure  P0P(S  :  in  out  STACK;  ITEM  :  out  ITEMTYPE)  is 
--  pre  -  The  stack  S  is  not  empty. 

post  -  ITEM  contains  the  most  recently  arrived  element  of  S-pre. 

S  no  longer  contains  ITEM. 

-■  exceptions  raised  STACK_UND£Rf LOW  if  S  is  empty. 

TEMP  POINTER  :  STACK; 
begin 

if  (EMPTY(S))  then 

raise  STACKUNOERf lOW; 
end  if ; 

ITEM  ;=  S, ELEMENT; 

TEMPPOINTER  S; 

S  S.NEXT; 

FREE_NOOE( TEMPPOINTER) ; 
end  POP; 

procedure  TOP(S  ;  in  STACK;  ITEM  :  out  ITEMTYPE)  is 
pre  -  The  stack  S  is  not  empty. 

post  -  ITEM  contains  the  most  recently  arrived  element  of  S-pre. 
exceptions  raised  STACKUNOERFLOW  if  S  is  empty, 
beg  1  n 

if  (EMPTY(S))  then 

raise  STACK  UNDERFLOW; 
end  if; 

ITEM  ;=  S. ELEMENT; 
end  (OP; 
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procudure  PUSH(S  ;  in  out  STACK;  ITEM  :  in  ITEMTYPE)  is 
--  pre  -  The  size  of  S  has  not  reached  its  bound. 

--  post  -  S  includes  ITEM  as  its  most  recently  arrived  element. 

--  e«ceptions  raised  -  STACKOVERFLOW  if  S  has  reached  its  bound. 

TEMP  POINTER  ;  STACK; 
beg  1 11 

if  (FULL(S))  then 

raise  STACKOVERFLOW; 
end  if; 

TEMPPOINTER  new  N0DE'(ITEM.  S); 

S  :=  TEMPPOINTER; 
end  PUSH; 

function  EMPTY{S  ;  in  STACK)  return  boolean  is 

--  post  -  If  the  stack  S  has  no  ITEMS  then  EMPTY  is  true,  else  EMPTY  is 
false. 

beg  1  n 

return  ( S  =  null); 
end  EMPTY; 

function  FULL(S  :  in  STACK)  '■eturn  boolean  is 

--  post  -  If  the  number  of  ITEMS  in  the  stack  S  has  reached  the  maximum 
allowed,  then  FULL  is  true,  else  FULL  is  false. 

TEMP  POINTER  ;  STACK; 
beg  in 

T£MP_POINTER  :=  new  NODE; 

FREE_NOOE(TEMP_POINTER); 
return  (FALSE); 
exception 

when  ST0RAGE_ERR0R  O 
return  ( TRUE  )  ; 
when  others  => 
raise; 
end  FULL; 

procedure  CREATE(S  :  in  out  STACK;  SUCCESS  :  out  boolean)  is 
'  post  -  If  a  stack  S  can  be  created  then  S  exists  and  is  empty,  and  SUCCESS 
IS  TRUE  else  SUCCESS  is  FALSE. 

beg  in 

S  ; =  null: 

SUCCESS  :=  TRUE: 
end  CREATE  ; 

procedure  0ISP0SE(S  :  in  out  STACK)  is 
-  post  -  S-pre  does  not  exist. 

TEMP  POINTER  :  STACK; 
beg  1  n 

while  ( S  !  -  null)  I oop 
TEMPPOINTER  : ^  S. 

S  ; =  S.NEXT  ; 

t  REF  NODE (  IFMP  PO I N M  R  )  ; 
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end  loop; 
end  DISPOSE; 


end  GENERIC_SrACK 
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